home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / CMPINT.C < prev    next >
C/C++ Source or Header  |  1992-03-01  |  94KB  |  3,113 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/src/microcode/RCS/cmpint.c,v 1.44 1992/02/24 22:10:33 jinx Exp $
  4.  
  5. Copyright (c) 1989-1992 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /*
  36.  *
  37.  * Compiled code interface.  Portable version.
  38.  * This file requires a bit of assembly language from cmpaux-md.m4
  39.  * See also the files cmpint.txt, cmpgc.h, and cmpint-md.h .
  40.  *
  41.  */
  42.  
  43. #ifdef HAS_COMPILER_SUPPORT
  44. /*
  45.  * Procedures in this file belong to the following categories:
  46.  *
  47.  * Local C procedures.  These are local procedures called only by
  48.  * other procedures in this file, and have been separated only for
  49.  * modularity reasons.  They are tagged with the C keyword `static'.
  50.  * They can return any C type.
  51.  *
  52.  * C utility procedures.  These procedures are called from C
  53.  * primitives and other subsystems and never leave the C world.  They
  54.  * constitute the compiled code data abstraction as far as other C
  55.  * parts of the Scheme "microcode" are concerned.  They are tagged
  56.  * with the noise word `C_UTILITY'.  They can return any C type.
  57.  *
  58.  * C interface entries.  These procedures are called from the
  59.  * interpreter (written in C) and ultimately enter the Scheme compiled
  60.  * code world by using the assembly language utility
  61.  * `C_to_interface'.  They are tagged with the noise word
  62.  * `C_TO_SCHEME'.  They MUST return a C long indicating what
  63.  * the interpreter should do next.
  64.  *
  65.  * Scheme interface utilities.  These procedures are called from the
  66.  * assembly language interface and return to it, and perform all the
  67.  * tasks that the compiler does not code inline.  They are referenced
  68.  * by compiled scheme code by index, and the assembly language
  69.  * interface fetches them from an array.  They are tagged with the
  70.  * noise word `SCHEME_UTILITY'.  They return a C structure (struct
  71.  * utility_result) which describes whether computation should proceed
  72.  * in the interpreter or in compiled code, and how.
  73.  *
  74.  */
  75.  
  76. /* Macro imports */
  77.  
  78. #include <stdio.h>
  79. #include "oscond.h"    /* Identify the operating system */
  80. #include "ansidecl.h"    /* Macros to support ANSI declarations */
  81. #include "dstack.h"    /* Dynamic-stack support */
  82. #include "config.h"     /* SCHEME_OBJECT type and machine dependencies */
  83. #include "types.h"      /* Needed by const.h */
  84. #include "const.h"      /* REGBLOCK_MINIMUM_LENGTH and PRIM_... codes */
  85. #include "object.h"     /* Making and destructuring Scheme objects */
  86. #include "intrpt.h"    /* Interrupt processing macros */
  87. #include "gc.h"        /* Request_GC, etc. */
  88. #include "sdata.h"    /* ENTITY_OPERATOR */
  89. #include "errors.h"     /* Error codes and Termination codes */
  90. #include "returns.h"    /* Return addresses in the interpreter */
  91. #include "fixobj.h"    /* To find the error handlers */
  92. #include "stack.h"    /* Stacks and stacklets */
  93. #include "interp.h"     /* Interpreter state and primitive destructuring */
  94. #include "default.h"    /* various definitions */
  95. #include "extern.h"    /* External decls (missing Cont_Debug, etc.) */
  96. #include "trap.h"       /* UNASSIGNED_OBJECT, TRAP_EXTENSION_TYPE */
  97. #include "prims.h"      /* LEXPR */
  98. #include "prim.h"    /* Primitive_Procedure_Table, etc. */
  99. #define IN_CMPINT_C
  100. #include "cmpgc.h"      /* Compiled code object relocation */
  101.  
  102. #ifndef FLUSH_I_CACHE_REGION
  103. #  define FLUSH_I_CACHE_REGION(addr, nwords) NOP()
  104. #endif
  105.  
  106. #ifndef PUSH_D_CACHE_REGION
  107. #  define PUSH_D_CACHE_REGION(addr, nwords) FLUSH_I_CACHE_REGION(addr, nwords)
  108. #endif
  109.  
  110. /* Make noise words invisible to the C compiler. */
  111.  
  112. #define C_UTILITY
  113. #define C_TO_SCHEME
  114. #define SCHEME_UTILITY
  115.  
  116. /* For clarity */
  117.  
  118. typedef char instruction;
  119.  
  120. #ifdef C_FUNC_PTR_IS_CLOSURE
  121. #  define REFENTRY(name) (name)
  122. #  define VARENTRY(name) instruction *name
  123. #  define EXTENTRY(name) extern instruction *name
  124. #else
  125. #  define REFENTRY(name) ((void (*)()) name)
  126. #  define VARENTRY(name) void (*name)()
  127. #  define EXTENTRY(name) extern void EXFUN (name, (void))
  128. #endif
  129.  
  130. /* Structure returned by SCHEME_UTILITYs */
  131.  
  132. struct utility_result
  133. {
  134.   VARENTRY (interface_dispatch);
  135.   union additional_info
  136.   {
  137.     long                code_to_interpreter;
  138.     instruction        *entry_point;
  139.   } extra;
  140. };
  141.  
  142. /* Some convenience macros */
  143.  
  144. #define RETURN_TO_C(code)                                               \
  145. do {                                                                    \
  146.   struct utility_result temp;                                           \
  147.                                                                         \
  148.   temp.interface_dispatch = (REFENTRY (interface_to_C));        \
  149.   temp.extra.code_to_interpreter = (code);                              \
  150.                                                                         \
  151.   return (temp);                                                        \
  152. } while (false)
  153.  
  154. #define RETURN_TO_SCHEME(ep)                                            \
  155. do {                                                                    \
  156.   struct utility_result temp;                                           \
  157.                                                                         \
  158.   temp.interface_dispatch = (REFENTRY (interface_to_scheme));        \
  159.   temp.extra.entry_point = ((instruction *) (ep));            \
  160.                                                                         \
  161.   return (temp);                                                        \
  162. } while (false)
  163.  
  164. #define RETURN_UNLESS_EXCEPTION(code, entry_point)                      \
  165. {                                                                       \
  166.   int return_code;                                                      \
  167.                                                                         \
  168.   return_code = (code);                                                 \
  169.   if (return_code == PRIM_DONE)                                         \
  170.   {                                                                     \
  171.     RETURN_TO_SCHEME (entry_point);                                     \
  172.   }                                                                     \
  173.   else                                                                  \
  174.   {                                                                     \
  175.     RETURN_TO_C (return_code);                                          \
  176.   }                                                                     \
  177. }
  178.  
  179. #define ENTRY_TO_OBJECT(entry)                        \
  180.   (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, ((SCHEME_OBJECT *) (entry))))
  181.  
  182. #define MAKE_CC_BLOCK(block_addr)                    \
  183.   (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr))
  184.  
  185. /* Imports from the rest of the "microcode" */
  186.  
  187. extern long
  188.   EXFUN (compiler_cache_operator, (void)),
  189.   EXFUN (compiler_cache_global_operator, (void)),
  190.   EXFUN (compiler_cache_lookup, (void)),
  191.   EXFUN (compiler_cache_assignment, (void));
  192.  
  193. /* Imports from assembly language */
  194.  
  195. extern long
  196.   EXFUN (C_to_interface, (void *));
  197.  
  198. EXTENTRY (interface_to_C);
  199. EXTENTRY (interface_to_scheme);
  200.  
  201. /* Exports to the rest of the "microcode" */
  202.  
  203. extern long
  204.   compiler_interface_version,
  205.   compiler_processor_type;
  206.  
  207. extern SCHEME_OBJECT
  208.   Registers[],
  209.   compiler_utilities,
  210.   return_to_interpreter;
  211.  
  212. extern C_UTILITY long
  213.   EXFUN (make_fake_uuo_link,
  214.      (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
  215.   EXFUN (make_uuo_link,
  216.      (SCHEME_OBJECT value, SCHEME_OBJECT extension,
  217.       SCHEME_OBJECT block, long offset)),
  218.   EXFUN (compiled_block_closure_p, (SCHEME_OBJECT block)),
  219.   EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT entry)),
  220.   EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT entry)),
  221.   EXFUN (coerce_to_compiled,
  222.      (SCHEME_OBJECT object, long arity, SCHEME_OBJECT *location));
  223.  
  224. extern C_UTILITY SCHEME_OBJECT
  225.   EXFUN (extract_uuo_link, (SCHEME_OBJECT block, long offset)),
  226.   EXFUN (extract_variable_cache,
  227.      (SCHEME_OBJECT extension, long offset)),
  228.   EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT block)),
  229.   EXFUN (compiled_block_environment, (SCHEME_OBJECT block)),
  230.   EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)),
  231.   * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT entry)),
  232.   EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry));
  233.  
  234. extern C_UTILITY void
  235.   EXFUN (compiler_initialize, (long fasl_p)),
  236.   EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
  237.   EXFUN (store_variable_cache,
  238.      (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
  239.   EXFUN (compiled_entry_type,
  240.      (SCHEME_OBJECT entry, long *buffer));
  241.  
  242. extern C_TO_SCHEME long
  243.   EXFUN (enter_compiled_expression, (void)),
  244.   EXFUN (apply_compiled_procedure, (void)),
  245.   EXFUN (return_to_compiled_code, (void)),
  246.   EXFUN (comp_link_caches_restart, (void)),
  247.   EXFUN (comp_op_lookup_trap_restart, (void)),
  248.   EXFUN (comp_interrupt_restart, (void)),
  249.   EXFUN (comp_assignment_trap_restart, (void)),
  250.   EXFUN (comp_cache_lookup_apply_restart, (void)),
  251.   EXFUN (comp_lookup_trap_restart, (void)),
  252.   EXFUN (comp_safe_lookup_trap_restart, (void)),
  253.   EXFUN (comp_unassigned_p_trap_restart, (void)),
  254.   EXFUN (comp_access_restart, (void)),
  255.   EXFUN (comp_reference_restart, (void)),
  256.   EXFUN (comp_safe_reference_restart, (void)),
  257.   EXFUN (comp_unassigned_p_restart, (void)),
  258.   EXFUN (comp_unbound_p_restart, (void)),
  259.   EXFUN (comp_assignment_restart, (void)),
  260.   EXFUN (comp_definition_restart, (void)),
  261.   EXFUN (comp_lookup_apply_restart, (void)),
  262.   EXFUN (comp_error_restart, (void));
  263.  
  264. extern SCHEME_UTILITY struct utility_result
  265.   EXFUN (comutil_return_to_interpreter, ()),
  266.   EXFUN (comutil_operator_apply_trap, ()),
  267.   EXFUN (comutil_operator_arity_trap, ()),
  268.   EXFUN (comutil_operator_entity_trap, ()),
  269.   EXFUN (comutil_operator_interpreted_trap, ()),
  270.   EXFUN (comutil_operator_lexpr_trap, ()),
  271.   EXFUN (comutil_operator_primitive_trap, ()),
  272.   EXFUN (comutil_operator_lookup_trap, ()),
  273.   EXFUN (comutil_operator_1_0_trap, ()),
  274.   EXFUN (comutil_operator_2_1_trap, ()),
  275.   EXFUN (comutil_operator_2_0_trap, ()),
  276.   EXFUN (comutil_operator_3_2_trap, ()),
  277.   EXFUN (comutil_operator_3_1_trap, ()),
  278.   EXFUN (comutil_operator_3_0_trap, ()),
  279.   EXFUN (comutil_operator_4_3_trap, ()),
  280.   EXFUN (comutil_operator_4_2_trap, ()),
  281.   EXFUN (comutil_operator_4_1_trap, ()),
  282.   EXFUN (comutil_operator_4_0_trap, ()),
  283.   EXFUN (comutil_primitive_apply, ()),
  284.   EXFUN (comutil_primitive_lexpr_apply, ()),
  285.   EXFUN (comutil_apply, ()),
  286.   EXFUN (comutil_error, ()),
  287.   EXFUN (comutil_lexpr_apply, ()),
  288.   EXFUN (comutil_link, ()),
  289.   EXFUN (comutil_interrupt_closure, ()),
  290.   EXFUN (comutil_interrupt_dlink, ()),
  291.   EXFUN (comutil_interrupt_procedure, ()),
  292.   EXFUN (comutil_interrupt_continuation, ()),
  293.   EXFUN (comutil_interrupt_ic_procedure, ()),
  294.   EXFUN (comutil_assignment_trap, ()),
  295.   EXFUN (comutil_cache_lookup_apply, ()),
  296.   EXFUN (comutil_lookup_trap, ()),
  297.   EXFUN (comutil_safe_lookup_trap, ()),
  298.   EXFUN (comutil_unassigned_p_trap, ()),
  299.   EXFUN (comutil_decrement, ()),
  300.   EXFUN (comutil_divide, ()),
  301.   EXFUN (comutil_equal, ()),
  302.   EXFUN (comutil_greater, ()),
  303.   EXFUN (comutil_increment, ()),
  304.   EXFUN (comutil_less, ()),
  305.   EXFUN (comutil_minus, ()),
  306.   EXFUN (comutil_modulo, ()),
  307.   EXFUN (comutil_multiply, ()),
  308.   EXFUN (comutil_negative, ()),
  309.   EXFUN (comutil_plus, ()),
  310.   EXFUN (comutil_positive, ()),
  311.   EXFUN (comutil_quotient, ()),
  312.   EXFUN (comutil_remainder, ()),
  313.   EXFUN (comutil_zero, ()),
  314.   EXFUN (comutil_access, ()),
  315.   EXFUN (comutil_reference, ()),
  316.   EXFUN (comutil_safe_reference, ()),
  317.   EXFUN (comutil_unassigned_p, ()),
  318.   EXFUN (comutil_unbound_p, ()),
  319.   EXFUN (comutil_assignment, ()),
  320.   EXFUN (comutil_definition, ()),
  321.   EXFUN (comutil_lookup_apply, ()),
  322.   EXFUN (comutil_primitive_error, ());
  323.  
  324. extern struct utility_result
  325.   (*(utility_table[]))();
  326.  
  327. /*
  328.   Utility table used by the assembly language interface to invoke
  329.   the SCHEME_UTILITY procedures that appear in this file.
  330.  
  331.   Important: Do NOT reorder this table without changing the indices
  332.   defined on the following page and the corresponding table in the
  333.   compiler.
  334.  */
  335.  
  336. struct utility_result
  337.   (*(utility_table[]))() =
  338. {
  339.   comutil_return_to_interpreter,        /* 0x0 */
  340.   comutil_operator_apply_trap,            /* 0x1 */
  341.   comutil_operator_arity_trap,            /* 0x2 */
  342.   comutil_operator_entity_trap,            /* 0x3 */
  343.   comutil_operator_interpreted_trap,        /* 0x4 */
  344.   comutil_operator_lexpr_trap,            /* 0x5 */
  345.   comutil_operator_primitive_trap,        /* 0x6 */
  346.   comutil_operator_lookup_trap,            /* 0x7 */
  347.   comutil_operator_1_0_trap,            /* 0x8 */
  348.   comutil_operator_2_1_trap,            /* 0x9 */
  349.   comutil_operator_2_0_trap,            /* 0xa */
  350.   comutil_operator_3_2_trap,            /* 0xb */
  351.   comutil_operator_3_1_trap,            /* 0xc */
  352.   comutil_operator_3_0_trap,            /* 0xd */
  353.   comutil_operator_4_3_trap,            /* 0xe */
  354.   comutil_operator_4_2_trap,            /* 0xf */
  355.   comutil_operator_4_1_trap,            /* 0x10 */
  356.   comutil_operator_4_0_trap,            /* 0x11 */
  357.   comutil_primitive_apply,            /* 0x12 */
  358.   comutil_primitive_lexpr_apply,        /* 0x13 */
  359.   comutil_apply,                /* 0x14 */
  360.   comutil_error,                /* 0x15 */
  361.   comutil_lexpr_apply,                /* 0x16 */
  362.   comutil_link,                    /* 0x17 */
  363.   comutil_interrupt_closure,            /* 0x18 */
  364.   comutil_interrupt_dlink,            /* 0x19 */
  365.   comutil_interrupt_procedure,            /* 0x1a */
  366.   comutil_interrupt_continuation,        /* 0x1b */
  367.   comutil_interrupt_ic_procedure,        /* 0x1c */
  368.   comutil_assignment_trap,            /* 0x1d */
  369.   comutil_cache_lookup_apply,            /* 0x1e */
  370.   comutil_lookup_trap,                /* 0x1f */
  371.   comutil_safe_lookup_trap,            /* 0x20 */
  372.   comutil_unassigned_p_trap,            /* 0x21 */
  373.   comutil_decrement,                /* 0x22 */
  374.   comutil_divide,                /* 0x23 */
  375.   comutil_equal,                /* 0x24 */
  376.   comutil_greater,                /* 0x25 */
  377.   comutil_increment,                /* 0x26 */
  378.   comutil_less,                    /* 0x27 */
  379.   comutil_minus,                /* 0x28 */
  380.   comutil_multiply,                /* 0x29 */
  381.   comutil_negative,                /* 0x2a */
  382.   comutil_plus,                    /* 0x2b */
  383.   comutil_positive,                /* 0x2c */
  384.   comutil_zero,                    /* 0x2d */
  385.   comutil_access,                /* 0x2e */
  386.   comutil_reference,                /* 0x2f */
  387.   comutil_safe_reference,            /* 0x30 */
  388.   comutil_unassigned_p,                /* 0x31 */
  389.   comutil_unbound_p,                /* 0x32 */
  390.   comutil_assignment,                /* 0x33 */
  391.   comutil_definition,                /* 0x34 */
  392.   comutil_lookup_apply,                /* 0x35 */
  393.   comutil_primitive_error,            /* 0x36 */
  394.   comutil_quotient,                /* 0x37 */
  395.   comutil_remainder,                /* 0x38 */
  396.   comutil_modulo                /* 0x39 */
  397.   };
  398.  
  399. /* These definitions reflect the indices into the table above. */
  400.  
  401. #define TRAMPOLINE_K_RETURN            0x0
  402. #define TRAMPOLINE_K_APPLY            0x1
  403. #define TRAMPOLINE_K_ARITY            0x2
  404. #define TRAMPOLINE_K_ENTITY            0x3
  405. #define TRAMPOLINE_K_INTERPRETED        0x4
  406. #define TRAMPOLINE_K_LEXPR_PRIMITIVE        0x5
  407. #define TRAMPOLINE_K_PRIMITIVE            0x6
  408. #define TRAMPOLINE_K_LOOKUP            0x7
  409. #define TRAMPOLINE_K_1_0            0x8
  410. #define TRAMPOLINE_K_2_1            0x9
  411. #define TRAMPOLINE_K_2_0            0xa
  412. #define TRAMPOLINE_K_3_2            0xb
  413. #define TRAMPOLINE_K_3_1            0xc
  414. #define TRAMPOLINE_K_3_0            0xd
  415. #define TRAMPOLINE_K_4_3            0xe
  416. #define TRAMPOLINE_K_4_2            0xf
  417. #define TRAMPOLINE_K_4_1            0x10
  418. #define TRAMPOLINE_K_4_0            0x11
  419.  
  420. #define TRAMPOLINE_K_OTHER            TRAMPOLINE_K_INTERPRETED
  421.  
  422. /* Main compiled code entry points.
  423.    These are the primary entry points that the interpreter
  424.    uses to execute compiled code.
  425.    The other entry points are special purpose return
  426.    points to compiled code invoked after the interpreter has been
  427.    employed to take corrective action (interrupt, error, etc).
  428.    They are coded adjacent to the place where the interpreter
  429.    is invoked.
  430.  */
  431.  
  432. C_TO_SCHEME long
  433. DEFUN_VOID (enter_compiled_expression)
  434. {
  435.   instruction *compiled_entry_address;
  436.   SCHEME_OBJECT *block_address, environment;
  437.   unsigned long length;
  438.  
  439.   compiled_entry_address =
  440.     ((instruction *) (OBJECT_ADDRESS (Fetch_Expression ())));
  441.   if ((COMPILED_ENTRY_FORMAT_WORD (compiled_entry_address)) !=
  442.       (FORMAT_WORD_EXPR))
  443.   {
  444.     /* It self evaluates. */
  445.     Val = (Fetch_Expression ());
  446.     return (C_to_interface ((instruction *) (OBJECT_ADDRESS (STACK_POP ()))));
  447.   }
  448.  
  449. #ifdef SPLIT_CACHES
  450.   /* This is a kludge to handle the first execution. */
  451.  
  452.   Get_Compiled_Block (block_address,
  453.               ((SCHEME_OBJECT *) compiled_entry_address));
  454.   length = (OBJECT_DATUM (*block_address));
  455.   environment = (block_address [length]);
  456.   if (!(ENVIRONMENT_P (environment)))
  457.   {
  458.     /* We could actually flush just the non-marked section.
  459.        The uuo-section will be flushed when linked.
  460.      */
  461.  
  462.     PUSH_D_CACHE_REGION (block_address, (length + 1));
  463.   }
  464. #endif /* SPLIT_CACHES */
  465.  
  466.   return (C_to_interface (compiled_entry_address));
  467. }
  468.  
  469. C_TO_SCHEME long
  470. DEFUN_VOID (apply_compiled_procedure)
  471. {
  472.   static long setup_compiled_invocation();
  473.   SCHEME_OBJECT nactuals, procedure;
  474.   instruction *procedure_entry;
  475.   long result;
  476.  
  477.   nactuals = (STACK_POP ());
  478.   procedure = (STACK_POP ());
  479.   procedure_entry = ((instruction *) (OBJECT_ADDRESS (procedure)));
  480.   result = setup_compiled_invocation ((OBJECT_DATUM (nactuals)),
  481.                                       procedure_entry);
  482.   if (result == PRIM_DONE)
  483.   {
  484.     /* Go into compiled code. */
  485.     return (C_to_interface (procedure_entry));
  486.   }
  487.   else
  488.   {
  489.     return (result);
  490.   }
  491. }
  492.  
  493. /* Note that this does not check that compiled_entry_address
  494.    is a valid return address. -- Should it?
  495.  */
  496.  
  497. C_TO_SCHEME long
  498. DEFUN_VOID (return_to_compiled_code)
  499. {
  500.   instruction *compiled_entry_address;
  501.  
  502.   compiled_entry_address =
  503.     ((instruction *) (OBJECT_ADDRESS (STACK_POP ())));
  504.   return (C_to_interface (compiled_entry_address));
  505. }
  506.  
  507. /* NOTE: In the rest of this file, number of arguments (or minimum
  508.    number of arguments, etc.) is always 1 greater than the number of
  509.    arguments (it includes the procedure object).
  510.  */
  511.  
  512. static long
  513. DEFUN (setup_compiled_invocation,
  514.        (nactuals, compiled_entry_address),
  515.        long nactuals AND
  516.        instruction *compiled_entry_address)
  517. {
  518.   static long setup_lexpr_invocation();
  519.   static SCHEME_OBJECT *open_gap();
  520.   long nmin, nmax, delta;               /* all +1 */
  521.  
  522.   nmax = (COMPILED_ENTRY_MAXIMUM_ARITY (compiled_entry_address));
  523.   if (nactuals == nmax)
  524.   {
  525.     /* Either the procedure takes exactly the number of arguments
  526.        given, or it has optional arguments, no rest argument, and
  527.        all the optional arguments have been provided.  Thus the
  528.        frame is in the right format and we are done.
  529.      */
  530.     return (PRIM_DONE);
  531.   }
  532.   nmin = (COMPILED_ENTRY_MINIMUM_ARITY (compiled_entry_address));
  533.   if (nmin < 0)
  534.   {
  535.     /* Not a procedure. */
  536.     STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address));
  537.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  538.     return (ERR_INAPPLICABLE_OBJECT);
  539.   }
  540.   if (nactuals < nmin)
  541.   {
  542.     /* Too few arguments. */
  543.     STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address));
  544.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  545.     return (ERR_WRONG_NUMBER_OF_ARGUMENTS);
  546.   }
  547.   delta = (nactuals - nmax);
  548.   if (delta <= 0)
  549.   {
  550.     /* The procedure takes optional arguments but no rest argument
  551.        and not all the optional arguments have been provided.
  552.        They must be defaulted.
  553.      */
  554.     ((void) (open_gap (nactuals, delta)));
  555.     return (PRIM_DONE);
  556.   }
  557.   if (nmax > 0)
  558.   {
  559.     /* Too many arguments */
  560.     STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address));
  561.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  562.     return (ERR_WRONG_NUMBER_OF_ARGUMENTS);
  563.   }
  564.   /* The procedure can take arbitrarily many arguments, ie.
  565.      it is a lexpr.
  566.    */
  567.   return (setup_lexpr_invocation (nactuals, nmax, compiled_entry_address));
  568. }
  569.  
  570. /* Default some optional parameters, and return the location
  571.    of the return address (one past the last actual argument location).
  572.  */
  573.  
  574. static SCHEME_OBJECT *
  575. DEFUN (open_gap,
  576.        (nactuals, delta),
  577.        register long nactuals AND register long delta)
  578. {
  579.   register SCHEME_OBJECT *gap_location, *source_location;
  580.  
  581.   /* Need to fill in optionals */
  582.  
  583.   gap_location = STACK_LOC (delta);
  584.   source_location = STACK_LOC (0);
  585.   Stack_Pointer = gap_location;
  586.   while ((--nactuals) > 0)
  587.   {
  588.     STACK_LOCATIVE_POP (gap_location) = STACK_LOCATIVE_POP (source_location);
  589.   }
  590.   delta = (- delta);
  591.   while ((--delta) >= 0)
  592.   {
  593.     STACK_LOCATIVE_POP (gap_location) = UNASSIGNED_OBJECT;
  594.   }
  595.   return (source_location);
  596. }
  597.  
  598. /* Setup a rest argument as appropriate. */
  599.  
  600. static long
  601. DEFUN (setup_lexpr_invocation,
  602.        (nactuals, nmax, entry_address),
  603.        register long nactuals AND register long nmax AND
  604.        instruction *entry_address)
  605. {
  606.   register long delta;
  607.  
  608.   /* nmax is negative! */
  609.  
  610.   delta = (nactuals + nmax);
  611.  
  612.   if (delta < 0)
  613.   {
  614.     /* Not enough arguments have been passed to allocate a list.
  615.        The missing optional arguments must be defaulted, and the
  616.        rest parameter needs to be set to the empty list.
  617.      */
  618.  
  619.     SCHEME_OBJECT *last_loc;
  620.  
  621.     last_loc = open_gap (nactuals, delta);
  622.     (STACK_LOCATIVE_PUSH (last_loc)) = EMPTY_LIST;
  623.     return (PRIM_DONE);
  624.   }
  625.   else if (delta == 0)
  626.   {
  627.     /* The number of arguments passed matches exactly the number of
  628.        formal paramters.  The last argument needs to be replaced by
  629.        a list containing it, but there is no need to pop anything
  630.        since the frame has the right size.
  631.        This does not check for gc!
  632.        The procedure should (and currently will) on entry.
  633.      */
  634.  
  635.     register SCHEME_OBJECT temp, *gap_location, *local_free;
  636.  
  637.     local_free = Free;
  638.     Free += 2;
  639.     gap_location = STACK_LOC (nactuals - 2);
  640.     temp = *gap_location;
  641.     *gap_location = (MAKE_POINTER_OBJECT (TC_LIST, local_free));
  642.     *local_free++ = temp;
  643.     *local_free = EMPTY_LIST;
  644.     return (PRIM_DONE);
  645.   }
  646.   else /* (delta > 0) */
  647.   {
  648.     /* The number of arguments passed is greater than the number of
  649.        formal parameters named by the procedure.  Excess arguments
  650.        need to be placed in a list passed at the last parameter
  651.        location. The extra arguments must then be popped from the stack.
  652.      */
  653.     long list_size;
  654.     register SCHEME_OBJECT *gap_location, *source_location;
  655.  
  656.     /* Allocate the list, and GC if necessary. */
  657.  
  658.     list_size = (2 * (delta + 1));
  659.     if (GC_Check (list_size))
  660.     {
  661.       Request_GC (list_size);
  662.       STACK_PUSH (ENTRY_TO_OBJECT (entry_address));
  663.       STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  664.       return (PRIM_APPLY_INTERRUPT);
  665.     }
  666.     gap_location = &Free[list_size];
  667.     Free = gap_location;
  668.  
  669.     /* Place the arguments in the list, and link it. */
  670.  
  671.     source_location = (STACK_LOC (nactuals - 1));
  672.     (*(--gap_location)) = EMPTY_LIST;
  673.  
  674.     while ((--delta) >= 0)
  675.     {
  676.       gap_location -= 2;
  677.       (*(gap_location + 1)) = (STACK_LOCATIVE_PUSH (source_location));
  678.       (*(gap_location)) = (MAKE_POINTER_OBJECT (TC_LIST, (gap_location + 1)));
  679.     }
  680.  
  681.     (*(--gap_location)) = (STACK_LOCATIVE_PUSH (source_location));
  682.  
  683.     /* Place the list at the appropriate location in the stack. */
  684.  
  685.     STACK_LOCATIVE_REFERENCE (source_location, 0) =
  686.       (MAKE_POINTER_OBJECT (TC_LIST, (gap_location)));
  687.  
  688.     /* Now move the arguments into their correct location in the stack
  689.        popping any unneeded locations.
  690.      */
  691.  
  692.     gap_location = (STACK_LOC (nactuals - 1));
  693.     STACK_LOCATIVE_INCREMENT (source_location);
  694.  
  695.     /* Remember that nmax is originally negative! */
  696.  
  697.     for (nmax = ((-nmax) - 1); ((--nmax) >= 0); )
  698.     {
  699.       (STACK_LOCATIVE_PUSH (gap_location)) =
  700.         (STACK_LOCATIVE_PUSH (source_location));
  701.     }
  702.     Stack_Pointer = gap_location;
  703.     return (PRIM_DONE);
  704.   }
  705. }
  706.  
  707. /*
  708.   SCHEME_UTILITYs
  709.  
  710.   Here's a mass of procedures that are called (via scheme_to_interface,
  711.   an assembly language hook) by compiled code to do various jobs.
  712.  */
  713.  
  714. /*
  715.   This is how compiled Scheme code normally returns back to the
  716.   Scheme interpreter.
  717.   It is invoked by a trampoline, which passes the address of the
  718.   trampoline storage block (empty) to it.
  719.  */
  720.  
  721. SCHEME_UTILITY struct utility_result
  722. DEFUN (comutil_return_to_interpreter,
  723.        (tramp_data, ignore_2, ignore_3, ignore_4),
  724.        SCHEME_OBJECT *tramp_data AND
  725.        long ignore_2 AND long ignore_3 AND long ignore_4)
  726. {
  727.   RETURN_TO_C (PRIM_DONE);
  728. }
  729.  
  730. /*
  731.   comutil_primitive_apply is used to invoked a C primitive.
  732.   Note that some C primitives (the so called interpreter hooks)
  733.   will not return normally, but will "longjmp" to the interpreter
  734.   instead.  Thus the assembly language invoking this should have
  735.   set up the appropriate locations in case this happens.
  736.   After invoking the primitive, it pops the arguments off the
  737.   Scheme stack, and proceeds by invoking the continuation on top
  738.   of the stack.
  739.  */
  740.  
  741. SCHEME_UTILITY struct utility_result
  742. DEFUN (comutil_primitive_apply,
  743.        (primitive, ignore_2, ignore_3, ignore_4),
  744.        SCHEME_OBJECT primitive AND
  745.        long ignore_2 AND long ignore_3 AND long ignore_4)
  746. { 
  747.   PRIMITIVE_APPLY (Val, primitive);
  748.   POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
  749.   RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
  750. }
  751.  
  752. /*
  753.   comutil_primitive_lexpr_apply is like comutil_primitive_apply
  754.   except that it is used to invoke primitives that take
  755.   an arbitrary number of arguments.
  756.   The number of arguments is in the REGBLOCK_LEXPR_ACTUALS slot
  757.   of the register block.
  758.  */
  759.  
  760. SCHEME_UTILITY struct utility_result
  761. DEFUN (comutil_primitive_lexpr_apply,
  762.        (primitive, ignore_2, ignore_3, ignore_4),
  763.        SCHEME_OBJECT primitive AND
  764.        long ignore_2 AND long ignore_3 AND long ignore_4)
  765. {
  766.   PRIMITIVE_APPLY (Val, primitive);
  767.   POP_PRIMITIVE_FRAME (((long) Regs[REGBLOCK_LEXPR_ACTUALS]));
  768.   RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
  769. }
  770.  
  771. /*
  772.   comutil_apply is used by compiled code to invoke an unknown
  773.   procedure.  It dispatches on its type to the correct place.  It
  774.   expects the procedure to invoke, and the number of arguments (+ 1).
  775.  */
  776.  
  777. SCHEME_UTILITY struct utility_result
  778. DEFUN (comutil_apply,
  779.        (procedure, nactuals, ignore_3, ignore_4),
  780.        SCHEME_OBJECT procedure AND
  781.        long nactuals AND long ignore_3 AND long ignore_4)
  782. {
  783.   switch (OBJECT_TYPE (procedure))
  784.   {
  785.     case TC_COMPILED_ENTRY:
  786.     callee_is_compiled:
  787.     {
  788.       instruction *entry_point;
  789.  
  790.       entry_point = ((instruction *) (OBJECT_ADDRESS (procedure)));
  791.       RETURN_UNLESS_EXCEPTION
  792.         ((setup_compiled_invocation (nactuals, entry_point)),
  793.          entry_point);
  794.     }
  795.  
  796.     case TC_ENTITY:
  797.     {
  798.       SCHEME_OBJECT operator;
  799.  
  800.       operator = (MEMORY_REF (procedure, ENTITY_OPERATOR));
  801.       if (!(COMPILED_CODE_ADDRESS_P (operator)))
  802.       {
  803.         goto callee_is_interpreted;
  804.       }
  805.       STACK_PUSH (procedure);           /* The entity itself */
  806.       procedure = operator;
  807.       nactuals += 1;
  808.       goto callee_is_compiled;
  809.     }
  810.     case TC_PRIMITIVE:
  811.     {
  812.       /* This code depends on the fact that unimplemented
  813.          primitives map into a "fake" primitive which accepts
  814.          any number of arguments, thus the arity test will
  815.          fail for unimplemented primitives.
  816.        */
  817.  
  818.       long arity;
  819.  
  820.       arity = (PRIMITIVE_ARITY (procedure));
  821.       if (arity == (nactuals - 1))
  822.       {
  823.         return (comutil_primitive_apply (procedure, 0, 0, 0));
  824.       }
  825.  
  826.       if (arity != LEXPR)
  827.       {
  828.         /* Wrong number of arguments. */
  829.         STACK_PUSH (procedure);
  830.         STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  831.         RETURN_TO_C (ERR_WRONG_NUMBER_OF_ARGUMENTS);
  832.       }
  833.       if (!(IMPLEMENTED_PRIMITIVE_P (procedure)))
  834.       {
  835.         /* Let the interpreter handle it. */
  836.         goto callee_is_interpreted;
  837.       }
  838.       /* "Lexpr" primitive. */
  839.       Regs[REGBLOCK_LEXPR_ACTUALS] = ((SCHEME_OBJECT) (nactuals - 1));
  840.       return (comutil_primitive_lexpr_apply (procedure, 0, 0, 0));
  841.     }
  842.  
  843.     callee_is_interpreted:
  844.     default:
  845.     {
  846.       STACK_PUSH (procedure);
  847.       STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  848.       RETURN_TO_C (PRIM_APPLY);
  849.     }
  850.   }
  851. }
  852.  
  853. /*
  854.   comutil_error is used by compiled code to signal an error.  It
  855.   expects the arguments to the error procedure to be pushed on the
  856.   stack, and is passed the number of arguments (+ 1).
  857. */
  858.  
  859. SCHEME_UTILITY struct utility_result
  860. DEFUN (comutil_error,
  861.        (nactuals, ignore_2, ignore_3, ignore_4),
  862.        long nactuals AND long ignore_2 AND long ignore_3 AND long ignore_4)
  863. {
  864.   SCHEME_OBJECT error_procedure;
  865.  
  866.   error_procedure = (Get_Fixed_Obj_Slot (Compiler_Err_Procedure));
  867.   return (comutil_apply (error_procedure, nactuals, 0, 0));
  868. }
  869.  
  870. /*
  871.   comutil_lexpr_apply is invoked to reformat the frame when compiled
  872.   code calls a known lexpr.  The actual arguments are on the stack,
  873.   and it is given the number of arguments (WITHOUT counting the entry
  874.   point being invoked), and the real entry point of the procedure.
  875.  
  876.   Important: This code assumes that it is always invoked with a valid
  877.   number of arguments (the compiler checked it), and will not check.
  878.  */
  879.  
  880. SCHEME_UTILITY struct utility_result
  881. DEFUN (comutil_lexpr_apply,
  882.        (entry_address, nactuals, ignore_3, ignore_4),
  883.        register instruction *entry_address AND
  884.        long nactuals AND
  885.        long ignore_3 AND long ignore_4)
  886. {
  887.   RETURN_UNLESS_EXCEPTION
  888.     ((setup_lexpr_invocation
  889.       ((nactuals + 1),
  890.        (COMPILED_ENTRY_MAXIMUM_ARITY (entry_address)),
  891.        entry_address)),
  892.      entry_address);
  893. }
  894.  
  895. /* Core of comutil_link and comp_link_caches_restart. */
  896.  
  897. static Boolean linking_cc_block_p = false;
  898.  
  899. static void
  900. DEFUN (abort_link_cc_block, (ap), PTR ap)
  901. {
  902.   linking_cc_block_p = (* ((Boolean *) (ap)));
  903.   return;
  904. }
  905.  
  906. static long
  907. DEFUN (link_cc_block,
  908.        (block_address, offset, last_header_offset,
  909.     sections, original_count, ret_add),
  910.        register SCHEME_OBJECT *block_address AND
  911.        register long offset AND
  912.        long last_header_offset AND
  913.        long sections AND
  914.        long original_count AND
  915.        instruction *ret_add)
  916. {
  917.   Boolean execute_p;
  918.   register long entry_size, count;
  919.   SCHEME_OBJECT block;
  920.   SCHEME_OBJECT header;
  921.   long result, kind, total_count;
  922.   long (*cache_handler)();
  923.  
  924.   transaction_begin ();
  925.   {
  926.     Boolean * ap = (dstack_alloc (sizeof (Boolean)));
  927.     *ap = linking_cc_block_p;
  928.     transaction_record_action (tat_abort, abort_link_cc_block, ap);
  929.   }
  930.   linking_cc_block_p = true;
  931.  
  932.   result = PRIM_DONE;
  933.   block = (MAKE_CC_BLOCK (block_address));
  934.  
  935.   while ((--sections) >= 0)
  936.   {
  937.     SCHEME_OBJECT * scan = &(block_address[last_header_offset]);
  938.     header = (*scan);
  939.  
  940.     kind = (READ_LINKAGE_KIND (header));
  941.     switch (kind)
  942.     {
  943.       case OPERATOR_LINKAGE_KIND:
  944.     cache_handler = compiler_cache_operator;
  945.  
  946.       handle_operator:
  947.         execute_p = true;
  948.     entry_size = EXECUTE_CACHE_ENTRY_SIZE;
  949.     START_OPERATOR_RELOCATION (scan);
  950.     count = (READ_OPERATOR_LINKAGE_COUNT (header));
  951.     break;
  952.  
  953.       case GLOBAL_OPERATOR_LINKAGE_KIND:
  954.     cache_handler = compiler_cache_global_operator;
  955.     goto handle_operator;
  956.  
  957.       case REFERENCE_LINKAGE_KIND:
  958.     cache_handler = compiler_cache_lookup;
  959.       handle_reference:
  960.     execute_p = false;
  961.     entry_size = 1;
  962.     count = (READ_CACHE_LINKAGE_COUNT (header));
  963.     break;
  964.  
  965.       case ASSIGNMENT_LINKAGE_KIND:
  966.     cache_handler = compiler_cache_assignment;
  967.     goto handle_reference;
  968.  
  969.       default:
  970.     offset += 1;
  971.     total_count = (READ_CACHE_LINKAGE_COUNT (header));
  972.     count = (total_count - 1);
  973.     result = ERR_COMPILED_CODE_ERROR;
  974.     goto back_out;
  975.     }
  976.  
  977.     /* This accomodates the re-entry case after a GC.
  978.        It undoes the effects of the "smash header" code below.
  979.      */
  980.  
  981.     if ((OBJECT_TYPE (header)) == TC_LINKAGE_SECTION)
  982.     {
  983.       count = (original_count - count);
  984.       total_count = original_count;
  985.     }
  986.     else
  987.     {
  988.       total_count = count;
  989.       if (execute_p)
  990.     offset += (FIRST_OPERATOR_LINKAGE_OFFSET - 1);
  991.     }
  992.  
  993.     block_address[last_header_offset] =
  994.       (MAKE_LINKAGE_SECTION_HEADER (kind, total_count));
  995.     for (offset += 1; ((--count) >= 0); offset += entry_size)
  996.     {
  997.       SCHEME_OBJECT name;
  998.  
  999.       if (!execute_p)
  1000.     name = (block_address[offset]);
  1001.       else
  1002.     EXTRACT_EXECUTE_CACHE_SYMBOL(name, &(block_address[offset]));
  1003.  
  1004.       result = ((*cache_handler)(name, block, offset));
  1005.       if (result != PRIM_DONE)
  1006.       {
  1007.         /* Save enough state to continue.
  1008.        Note that offset is decremented to compensate for it being
  1009.        incremented by the for loop header.
  1010.        Similary sections and count are incremented to compensate
  1011.        for loop headers pre-decrementing.
  1012.        count is saved although it's not needed for re-entry to
  1013.        match the assembly language versions.
  1014.      */
  1015.  
  1016.   back_out:
  1017.     if (execute_p)
  1018.       END_OPERATOR_RELOCATION (&(block_address[offset]));
  1019.         STACK_PUSH (ENTRY_TO_OBJECT (ret_add));
  1020.         STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (sections + 1));
  1021.         STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (last_header_offset));
  1022.         STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (offset - 1));
  1023.         STACK_PUSH (block);
  1024.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (count + 1));
  1025.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (total_count));
  1026.  
  1027.         Store_Expression (SHARP_F);
  1028.         Store_Return (RC_COMP_LINK_CACHES_RESTART);
  1029.         Save_Cont ();
  1030.  
  1031.         /* Smash header for the garbage collector.
  1032.            It is smashed back on return.  See the comment above.
  1033.          */
  1034.  
  1035.         block_address[last_header_offset] =
  1036.           (MAKE_LINKAGE_SECTION_HEADER (kind, (total_count - (count + 1))));
  1037.     goto exit_proc;
  1038.       }
  1039.     }
  1040.     if (execute_p)
  1041.       END_OPERATOR_RELOCATION (&(block_address[offset - 1]));
  1042.     last_header_offset = offset;
  1043.   }
  1044.  
  1045. exit_proc:
  1046.   /* Rather than commit, since we want to undo */
  1047.   transaction_abort ();
  1048.   PUSH_D_CACHE_REGION (block_address,
  1049.                (((unsigned long) (*block_address)) + 1));
  1050.   return (result);
  1051. }
  1052.  
  1053. /*
  1054.   comutil_link is used to initialize all the variable cache slots for
  1055.   a compiled code block.  It is called at load time, by the compiled
  1056.   code itself.  It assumes that the return address has been saved on
  1057.   the stack.
  1058.   If an error occurs during linking, or an interrupt must be processed
  1059.   (because of the need to GC, etc.), it backs out and sets up a return
  1060.   code that will invoke comp_link_caches_restart when the error/interrupt
  1061.   processing is done.
  1062. */
  1063.  
  1064. SCHEME_UTILITY struct utility_result
  1065. DEFUN (comutil_link,
  1066.        (ret_add, block_address, constant_address, sections),
  1067.        instruction *ret_add AND
  1068.        SCHEME_OBJECT *block_address AND SCHEME_OBJECT *constant_address AND
  1069.        long sections)
  1070. {
  1071.   long offset;
  1072.  
  1073.   offset = (constant_address - block_address);
  1074.  
  1075.   RETURN_UNLESS_EXCEPTION
  1076.     ((link_cc_block (block_address,
  1077.                      offset,
  1078.                      offset,
  1079.                      sections,
  1080.                      -1,
  1081.                      ret_add)),
  1082.      ret_add);
  1083. }
  1084.  
  1085. /*
  1086.   comp_link_caches_restart is used to continue the linking process
  1087.   started by comutil_link after the garbage collector has run.
  1088.   It expects the top of the stack to be as left by link_cc_block.
  1089.  */
  1090.  
  1091. C_TO_SCHEME long
  1092. DEFUN_VOID (comp_link_caches_restart)
  1093. {
  1094.   SCHEME_OBJECT block, environment;
  1095.   long original_count, offset, last_header_offset, sections, code;
  1096.   instruction *ret_add;
  1097.  
  1098.   original_count = (OBJECT_DATUM (STACK_POP()));
  1099.   STACK_POP ();                    /* Loop count, for debugger */
  1100.   block = (STACK_POP ());
  1101.   environment = (compiled_block_environment (block));
  1102.   Store_Env (environment);
  1103.   offset = (OBJECT_DATUM (STACK_POP ()));
  1104.   last_header_offset = (OBJECT_DATUM (STACK_POP ()));
  1105.   sections = (OBJECT_DATUM (STACK_POP ()));
  1106.   ret_add = ((instruction *) (OBJECT_ADDRESS (STACK_POP ())));
  1107.   code = (link_cc_block ((OBJECT_ADDRESS (block)),
  1108.                          offset,
  1109.                          last_header_offset,
  1110.                          sections,
  1111.                          original_count,
  1112.                          ret_add));
  1113.   if (code == PRIM_DONE)
  1114.   {
  1115.     /* Return to the block being linked. */
  1116.     return (C_to_interface (ret_add));
  1117.   }
  1118.   else
  1119.   {
  1120.     /* Another GC or error.  We should be ready for back-out. */
  1121.     return (code);
  1122.   }
  1123. }
  1124.  
  1125. /* TRAMPOLINE code
  1126.    When a free variable appears in operator position in compiled code,
  1127.    there must be a directly callable procedure in the corresponding
  1128.    execute cache cell.  If, at link time, there is no appropriate
  1129.    value for the free variable, a fake compiled Scheme procedure that
  1130.    calls one of these procedures will be placed into the cell instead.
  1131.  
  1132.    The trampolines themselves are made by make_uuo_link,
  1133.    make_fake_uuo_link, and coerce_to_compiled.  The trampoline looks
  1134.    like a Scheme closure, containing some code to jump to one of
  1135.    these procedures and additional information to be used by the
  1136.    procedure.
  1137.  
  1138.    These procedures expect a single argument, the address of the
  1139.    information block where they can find the relevant data, typically
  1140.    the procedure to invoke and the number of arguments to invoke it
  1141.    with.
  1142. */
  1143.  
  1144. SCHEME_UTILITY struct utility_result
  1145. DEFUN (comutil_operator_apply_trap,
  1146.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1147.        SCHEME_OBJECT *tramp_data AND
  1148.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1149. {
  1150.   /* Used by coerce_to_compiled.  TRAMPOLINE_K_APPLY */
  1151.  
  1152.   return (comutil_apply ((tramp_data[0]),
  1153.              (OBJECT_DATUM (tramp_data[1])),
  1154.              0, 0));
  1155. }
  1156.  
  1157. SCHEME_UTILITY struct utility_result
  1158. DEFUN (comutil_operator_arity_trap,
  1159.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1160.        SCHEME_OBJECT *tramp_data AND
  1161.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1162. {
  1163.   /* Linker saw an argument count mismatch. TRAMPOLINE_K_ARITY */
  1164.  
  1165.   return (comutil_apply ((tramp_data[0]),
  1166.              (OBJECT_DATUM (tramp_data[1])),
  1167.              0, 0));
  1168. }
  1169.  
  1170. SCHEME_UTILITY struct utility_result
  1171. DEFUN (comutil_operator_entity_trap,
  1172.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1173.        SCHEME_OBJECT *tramp_data AND
  1174.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1175. {
  1176.   /* Linker saw an entity to be applied. TRAMPOLINE_K_ENTITY */
  1177.  
  1178.   return (comutil_apply ((tramp_data[0]),
  1179.              (OBJECT_DATUM (tramp_data[1])),
  1180.              0, 0));
  1181. }
  1182.  
  1183. SCHEME_UTILITY struct utility_result
  1184. DEFUN (comutil_operator_interpreted_trap,
  1185.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1186.        SCHEME_OBJECT *tramp_data AND
  1187.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1188. {
  1189.   /* Linker saw an interpreted procedure or a procedure that it cannot
  1190.      link directly.  TRAMPOLINE_K_INTERPRETED
  1191.    */
  1192.  
  1193.   return (comutil_apply ((tramp_data[0]),
  1194.              (OBJECT_DATUM (tramp_data[1])),
  1195.              0, 0));
  1196. }
  1197.  
  1198. SCHEME_UTILITY struct utility_result
  1199. DEFUN (comutil_operator_lexpr_trap,
  1200.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1201.        SCHEME_OBJECT *tramp_data AND
  1202.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1203. {
  1204.   /* Linker saw a primitive of arbitrary number of arguments.
  1205.      TRAMPOLINE_K_LEXPR_PRIMITIVE
  1206.    */
  1207.  
  1208.   Regs[REGBLOCK_LEXPR_ACTUALS] =
  1209.     ((SCHEME_OBJECT) ((OBJECT_DATUM (tramp_data[1])) - 1));
  1210.   return (comutil_primitive_lexpr_apply ((tramp_data[0]), 0, 0, 0));
  1211. }
  1212.  
  1213. SCHEME_UTILITY struct utility_result
  1214. DEFUN (comutil_operator_primitive_trap,
  1215.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1216.        SCHEME_OBJECT *tramp_data AND
  1217.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1218. {
  1219.   /* Linker saw a primitive of fixed matching arity. TRAMPOLINE_K_PRIMITIVE */
  1220.  
  1221.   return (comutil_primitive_apply ((tramp_data[0]), 0, 0, 0));
  1222. }
  1223.  
  1224. /* The linker either couldn't find a binding or the binding was
  1225.    unassigned, unbound, or a deep-bound (parallel processor) fluid.
  1226.    This must report the correct name of the missing variable and the
  1227.    environment in which the lookup begins for the error cases, or do
  1228.    the correct deep reference for fluids.
  1229.  
  1230.    "extension" is the linker object corresponding to the operator
  1231.    variable (it contains the actual value cell, the name, and linker
  1232.    tables). code_block and offset point to the cache cell in question.
  1233.    tramp_data contains extension, code_block, offset.  TRAMPOLINE_K_LOOKUP
  1234. */
  1235.  
  1236. SCHEME_UTILITY struct utility_result
  1237. DEFUN (comutil_operator_lookup_trap,
  1238.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1239.        SCHEME_OBJECT *tramp_data AND
  1240.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1241. {
  1242.   extern long complr_operator_reference_trap();
  1243.   SCHEME_OBJECT true_operator, *cache_cell;
  1244.   long code, nargs;
  1245.  
  1246.   code = (complr_operator_reference_trap (&true_operator, (tramp_data[0])));
  1247.   cache_cell = (MEMORY_LOC ((tramp_data[1]),
  1248.                 (OBJECT_DATUM (tramp_data[2]))));
  1249.   EXTRACT_EXECUTE_CACHE_ARITY (nargs, cache_cell);
  1250.   if (code == PRIM_DONE)
  1251.   {
  1252.     return (comutil_apply (true_operator, nargs, 0, 0));
  1253.   }
  1254.   else /* Error or interrupt */
  1255.   {
  1256.     SCHEME_OBJECT trampoline, environment, name;
  1257.  
  1258.     /* This could be done by bumpint tramp_data to the entry point.
  1259.        It would probably be better.
  1260.      */
  1261.     EXTRACT_EXECUTE_CACHE_ADDRESS (trampoline, cache_cell);
  1262.     environment = (compiled_block_environment (tramp_data[1]));
  1263.     name = (compiler_var_error ((tramp_data[0]), environment));
  1264.  
  1265.     STACK_PUSH (ENTRY_TO_OBJECT (trampoline));
  1266.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nargs));    /* For debugger */
  1267.     STACK_PUSH (environment);                /* For debugger */
  1268.     STACK_PUSH (name);                    /* For debugger */
  1269.     Store_Expression (SHARP_F);
  1270.     Store_Return (RC_COMP_OP_REF_TRAP_RESTART);
  1271.     Save_Cont ();
  1272.     RETURN_TO_C (code);
  1273.   }
  1274. }
  1275.  
  1276. /*
  1277.   Re-start after processing an error/interrupt encountered in the previous
  1278.   utility.
  1279.   Extract the new trampoline or procedure (the user may have defined the
  1280.   missing variable) and invoke it.
  1281.  */
  1282.  
  1283. C_TO_SCHEME long
  1284. DEFUN_VOID (comp_op_lookup_trap_restart)
  1285. {
  1286.   SCHEME_OBJECT *old_trampoline, code_block, new_procedure;
  1287.   long offset;
  1288.  
  1289.   /* Discard name, env. and nargs */
  1290.  
  1291.   Stack_Pointer = (STACK_LOC (3));
  1292.   old_trampoline = (OBJECT_ADDRESS (STACK_POP ()));
  1293.   code_block = ((TRAMPOLINE_STORAGE (old_trampoline))[1]);
  1294.   offset = (OBJECT_DATUM ((TRAMPOLINE_STORAGE (old_trampoline))[2]));
  1295.   EXTRACT_EXECUTE_CACHE_ADDRESS (new_procedure,
  1296.                  (MEMORY_LOC (code_block, offset)));
  1297.   return (C_to_interface ((instruction *) new_procedure));
  1298. }
  1299.  
  1300. /* ARITY Mismatch handling
  1301.    These receive the entry point as an argument and must fill the
  1302.    Scheme stack with the missing unassigned values.
  1303.    They are invoked by TRAMPOLINE_K_n_m where n and m are the same
  1304.    as in the name of the procedure.
  1305.    The single item of information in the trampoline data area is
  1306.    the real procedure to invoke.  All the arguments are on the
  1307.    Scheme stack.
  1308.  */
  1309.  
  1310. SCHEME_UTILITY struct utility_result
  1311. DEFUN (comutil_operator_1_0_trap,
  1312.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1313.        SCHEME_OBJECT *tramp_data AND
  1314.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1315. {
  1316.   STACK_PUSH (UNASSIGNED_OBJECT);
  1317.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1318. }
  1319.  
  1320. SCHEME_UTILITY struct utility_result
  1321. DEFUN (comutil_operator_2_1_trap,
  1322.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1323.        SCHEME_OBJECT *tramp_data AND
  1324.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1325. {
  1326.   SCHEME_OBJECT Top;
  1327.  
  1328.   Top = STACK_POP ();
  1329.   STACK_PUSH (UNASSIGNED_OBJECT);
  1330.   STACK_PUSH (Top);
  1331.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1332. }
  1333.  
  1334. SCHEME_UTILITY struct utility_result
  1335. DEFUN (comutil_operator_2_0_trap,
  1336.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1337.        SCHEME_OBJECT *tramp_data AND
  1338.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1339. {
  1340.   STACK_PUSH (UNASSIGNED_OBJECT);
  1341.   STACK_PUSH (UNASSIGNED_OBJECT);
  1342.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1343. }
  1344.  
  1345. SCHEME_UTILITY struct utility_result
  1346. DEFUN (comutil_operator_3_2_trap,
  1347.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1348.        SCHEME_OBJECT *tramp_data AND
  1349.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1350. {
  1351.   SCHEME_OBJECT Top, Next;
  1352.  
  1353.   Top = STACK_POP ();
  1354.   Next = STACK_POP ();
  1355.   STACK_PUSH (UNASSIGNED_OBJECT);
  1356.   STACK_PUSH (Next);
  1357.   STACK_PUSH (Top);
  1358.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1359. }
  1360.  
  1361. SCHEME_UTILITY struct utility_result
  1362. DEFUN (comutil_operator_3_1_trap,
  1363.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1364.        SCHEME_OBJECT *tramp_data AND
  1365.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1366. {
  1367.   SCHEME_OBJECT Top;
  1368.  
  1369.   Top = STACK_POP ();
  1370.   STACK_PUSH (UNASSIGNED_OBJECT);
  1371.   STACK_PUSH (UNASSIGNED_OBJECT);
  1372.   STACK_PUSH (Top);
  1373.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1374. }
  1375.  
  1376. SCHEME_UTILITY struct utility_result
  1377. DEFUN (comutil_operator_3_0_trap,
  1378.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1379.        SCHEME_OBJECT *tramp_data AND
  1380.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1381. {
  1382.   STACK_PUSH (UNASSIGNED_OBJECT);
  1383.   STACK_PUSH (UNASSIGNED_OBJECT);
  1384.   STACK_PUSH (UNASSIGNED_OBJECT);
  1385.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1386. }
  1387.  
  1388. SCHEME_UTILITY struct utility_result
  1389. DEFUN (comutil_operator_4_3_trap,
  1390.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1391.        SCHEME_OBJECT *tramp_data AND
  1392.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1393. {
  1394.   SCHEME_OBJECT Top, Middle, Bottom;
  1395.  
  1396.   Top = STACK_POP ();
  1397.   Middle = STACK_POP ();
  1398.   Bottom = STACK_POP ();
  1399.  
  1400.   STACK_PUSH (UNASSIGNED_OBJECT);
  1401.   STACK_PUSH (Bottom);
  1402.   STACK_PUSH (Middle);
  1403.   STACK_PUSH (Top);
  1404.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1405. }
  1406.  
  1407. SCHEME_UTILITY struct utility_result
  1408. DEFUN (comutil_operator_4_2_trap,
  1409.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1410.        SCHEME_OBJECT *tramp_data AND
  1411.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1412. {
  1413.   SCHEME_OBJECT Top, Next;
  1414.  
  1415.   Top = STACK_POP ();
  1416.   Next = STACK_POP ();
  1417.   STACK_PUSH (UNASSIGNED_OBJECT);
  1418.   STACK_PUSH (UNASSIGNED_OBJECT);
  1419.   STACK_PUSH (Next);
  1420.   STACK_PUSH (Top);
  1421.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1422. }
  1423.  
  1424. SCHEME_UTILITY struct utility_result
  1425. DEFUN (comutil_operator_4_1_trap,
  1426.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1427.        SCHEME_OBJECT *tramp_data AND
  1428.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1429. {
  1430.   SCHEME_OBJECT Top;
  1431.  
  1432.   Top = STACK_POP ();
  1433.   STACK_PUSH (UNASSIGNED_OBJECT);
  1434.   STACK_PUSH (UNASSIGNED_OBJECT);
  1435.   STACK_PUSH (UNASSIGNED_OBJECT);
  1436.   STACK_PUSH (Top);
  1437.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1438. }
  1439.  
  1440. SCHEME_UTILITY struct utility_result
  1441. DEFUN (comutil_operator_4_0_trap,
  1442.        (tramp_data, ignore_2, ignore_3, ignore_4),
  1443.        SCHEME_OBJECT *tramp_data AND
  1444.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1445. {
  1446.   STACK_PUSH (UNASSIGNED_OBJECT);
  1447.   STACK_PUSH (UNASSIGNED_OBJECT);
  1448.   STACK_PUSH (UNASSIGNED_OBJECT);
  1449.   STACK_PUSH (UNASSIGNED_OBJECT);
  1450.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1451. }
  1452.  
  1453. /* INTERRUPT/GC from Scheme
  1454.    The next four procedures are called from compiled code at the start
  1455.    (respectively) of a closure, continuation, interpreter compatible
  1456.    procedure, or ordinary (not closed) procedure if an interrupt has
  1457.    been detected.  They return to the interpreter if the interrupt is
  1458.    invalid after saving the state necessary to restart the compiled
  1459.    code.
  1460.  
  1461.    The code that handles RC_COMP_INTERRUPT_RESTART in interp.c will
  1462.    return control to comp_interrupt_restart (below).  This assumes
  1463.    that the Scheme stack contains a compiled code entry address (start
  1464.    of continuation, procedure, etc.).  The Expression register saved
  1465.    with the continuation is a piece of state that will be returned to
  1466.    Val and Env (both) upon return.
  1467. */
  1468.  
  1469. #define GC_DESIRED_P()        (Free >= MemTop)
  1470.  
  1471. #define TEST_GC_NEEDED()                        \
  1472. {                                    \
  1473.   if (GC_DESIRED_P())                            \
  1474.   {                                    \
  1475.     Request_GC(Free-MemTop);                        \
  1476.   }                                    \
  1477. }
  1478.  
  1479. /* Called with no arguments, closure at top of (Scheme) stack.
  1480.    If the interrupt is disabled, the closure is re-invoked.
  1481.  */
  1482.  
  1483. SCHEME_UTILITY struct utility_result
  1484. DEFUN (comutil_interrupt_closure,
  1485.        (ignore_1, ignore_2, ignore_3, ignore_4),
  1486.        long ignore_1 AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1487. {
  1488.   TEST_GC_NEEDED();
  1489.   if ((PENDING_INTERRUPTS()) == 0)
  1490.   {
  1491.     SCHEME_OBJECT entry_point;
  1492.  
  1493.     EXTRACT_CLOSURE_ENTRY_ADDRESS (entry_point,
  1494.                    (OBJECT_ADDRESS (STACK_REF (0))));
  1495.     ADJUST_CLOSURE_AT_CALL (entry_point, (STACK_REF (0)));
  1496.     RETURN_TO_SCHEME (((instruction *) entry_point) +
  1497.               CLOSURE_SKIPPED_CHECK_OFFSET);
  1498.   }
  1499.   else
  1500.   {
  1501.     /* Return to interpreter to handle interrupt */
  1502.     
  1503.     STACK_PUSH (SHARP_F);
  1504.     Store_Expression (SHARP_F);
  1505.     Store_Return (RC_COMP_INTERRUPT_RESTART);
  1506.     Save_Cont ();
  1507.     RETURN_TO_C (PRIM_INTERRUPT);
  1508.   }
  1509. }
  1510.  
  1511. /* State is the live data; no entry point on the stack.
  1512.  */
  1513.  
  1514. static struct utility_result
  1515. DEFUN (compiler_interrupt_common,
  1516.        (entry_point, offset, state),
  1517.        instruction *entry_point AND
  1518.        long offset AND
  1519.        SCHEME_OBJECT state)
  1520. {
  1521.   TEST_GC_NEEDED();
  1522.   if ((PENDING_INTERRUPTS()) == 0)
  1523.   {
  1524.     Store_Env (state);
  1525.     Val = state;
  1526.     RETURN_TO_SCHEME (entry_point + offset);
  1527.   }
  1528.   else
  1529.   {
  1530.     STACK_PUSH (ENTRY_TO_OBJECT (entry_point));
  1531.     STACK_PUSH (state);
  1532.     Store_Expression (SHARP_F);
  1533.     Store_Return (RC_COMP_INTERRUPT_RESTART);
  1534.     Save_Cont ();
  1535.     RETURN_TO_C (PRIM_INTERRUPT);
  1536.   }
  1537. }
  1538.  
  1539. SCHEME_UTILITY struct utility_result
  1540. DEFUN (comutil_interrupt_dlink,
  1541.        (entry_point, dlink, ignore_3, ignore_4),
  1542.        instruction *entry_point AND
  1543.        SCHEME_OBJECT *dlink AND
  1544.        long ignore_3 AND long ignore_4)
  1545. {
  1546.   return
  1547.     (compiler_interrupt_common(entry_point,
  1548.                    ENTRY_SKIPPED_CHECK_OFFSET,
  1549.                    MAKE_POINTER_OBJECT(TC_STACK_ENVIRONMENT,
  1550.                            dlink)));
  1551. }
  1552.  
  1553. SCHEME_UTILITY struct utility_result
  1554. DEFUN (comutil_interrupt_procedure,
  1555.        (entry_point, ignore_2, ignore_3, ignore_4),
  1556.        instruction *entry_point AND
  1557.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1558. {
  1559.   return (compiler_interrupt_common(entry_point,
  1560.                     ENTRY_SKIPPED_CHECK_OFFSET,
  1561.                     SHARP_F));
  1562. }
  1563.  
  1564. /* Val has live data, and there is no entry address on the stack */
  1565.  
  1566. SCHEME_UTILITY struct utility_result
  1567. DEFUN (comutil_interrupt_continuation,
  1568.        (return_address, ignore_2, ignore_3, ignore_4),
  1569.        instruction *return_address AND
  1570.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1571. {
  1572.   return (compiler_interrupt_common (return_address,
  1573.                      ENTRY_SKIPPED_CHECK_OFFSET,
  1574.                      Val));
  1575. }
  1576.  
  1577. /* Env has live data; no entry point on the stack */
  1578.  
  1579. SCHEME_UTILITY struct utility_result
  1580. DEFUN (comutil_interrupt_ic_procedure,
  1581.        (entry_point, ignore_2, ignore_3, ignore_4),
  1582.        instruction *entry_point AND
  1583.        long ignore_2 AND long ignore_3 AND long ignore_4)
  1584. {
  1585.   return (compiler_interrupt_common (entry_point,
  1586.                      ENTRY_SKIPPED_CHECK_OFFSET,
  1587.                      (Fetch_Env())));
  1588. }
  1589.  
  1590. C_TO_SCHEME long
  1591. DEFUN_VOID (comp_interrupt_restart)
  1592. {
  1593.   SCHEME_OBJECT state;
  1594.  
  1595.   state = (STACK_POP ());
  1596.   Store_Env (state);
  1597.   Val = state;
  1598.   return (C_to_interface ((instruction *) (OBJECT_ADDRESS (STACK_POP ()))));
  1599. }
  1600.  
  1601. /* Other TRAPS */
  1602.  
  1603. /* Assigning a variable that has a trap in it (except unassigned) */
  1604.  
  1605. SCHEME_UTILITY struct utility_result
  1606. DEFUN (comutil_assignment_trap,
  1607.        (return_address, extension_addr, value, ignore_4),
  1608.        instruction *return_address AND
  1609.        SCHEME_OBJECT *extension_addr AND SCHEME_OBJECT value AND
  1610.        long ignore_4)
  1611. {
  1612.   extern long compiler_assignment_trap();
  1613.   SCHEME_OBJECT extension;
  1614.   long code;
  1615.  
  1616.   extension = (MAKE_POINTER_OBJECT (TC_QUAD, extension_addr));
  1617.   code = (compiler_assignment_trap (extension, value));
  1618.   if (code == PRIM_DONE)
  1619.   {
  1620.     RETURN_TO_SCHEME (return_address);
  1621.   }
  1622.   else
  1623.   {
  1624.     SCHEME_OBJECT block, environment, name, sra;
  1625.  
  1626.     sra = (ENTRY_TO_OBJECT (return_address));
  1627.     STACK_PUSH (sra);
  1628.     STACK_PUSH (value);
  1629.     block = (compiled_entry_to_block (sra));
  1630.     environment = (compiled_block_environment (block));
  1631.     STACK_PUSH (environment);
  1632.     name = (compiler_var_error (extension, environment));
  1633.     STACK_PUSH (name);
  1634.     Store_Expression (SHARP_F);
  1635.     Store_Return (RC_COMP_ASSIGNMENT_TRAP_RESTART);
  1636.     Save_Cont ();
  1637.     RETURN_TO_C (code);
  1638.   }
  1639. }
  1640.  
  1641. C_TO_SCHEME long
  1642. DEFUN_VOID (comp_assignment_trap_restart)
  1643. {
  1644.   extern long Symbol_Lex_Set();
  1645.   SCHEME_OBJECT name, environment, value;
  1646.   long code;
  1647.  
  1648.   name = (STACK_POP ());
  1649.   environment = (STACK_POP ());
  1650.   value = (STACK_POP ());
  1651.   code = (Symbol_Lex_Set (environment, name, value));
  1652.   if (code == PRIM_DONE)
  1653.   {
  1654.     return (C_to_interface (OBJECT_ADDRESS (STACK_POP ())));
  1655.   }
  1656.   else
  1657.   {
  1658.     STACK_PUSH (value);
  1659.     STACK_PUSH (environment);
  1660.     STACK_PUSH (name);
  1661.     Store_Expression (SHARP_F);
  1662.     Store_Return (RC_COMP_ASSIGNMENT_TRAP_RESTART);
  1663.     Save_Cont ();
  1664.     return (code);
  1665.   }
  1666. }
  1667.  
  1668. SCHEME_UTILITY struct utility_result
  1669. DEFUN (comutil_cache_lookup_apply,
  1670.        (extension_addr, block_address, nactuals, ignore_4),
  1671.        SCHEME_OBJECT *extension_addr AND SCHEME_OBJECT *block_address AND
  1672.        long nactuals AND long ignore_4)
  1673. {
  1674.   extern long compiler_lookup_trap();
  1675.   SCHEME_OBJECT extension;
  1676.   long code;
  1677.  
  1678.   extension = (MAKE_POINTER_OBJECT (TC_QUAD, extension_addr));
  1679.   code = (compiler_lookup_trap (extension));
  1680.   if (code == PRIM_DONE)
  1681.   {
  1682.     return (comutil_apply (Val, nactuals, 0, 0));
  1683.   }
  1684.   else
  1685.   {
  1686.     SCHEME_OBJECT block, environment, name;
  1687.  
  1688.     block = (MAKE_CC_BLOCK (block_address));
  1689.     STACK_PUSH (block);
  1690.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  1691.     environment = (compiled_block_environment (block));
  1692.     STACK_PUSH (environment);
  1693.     name = (compiler_var_error (extension, environment));
  1694.     STACK_PUSH (name);
  1695.     Store_Expression (SHARP_F);
  1696.     Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART);
  1697.     Save_Cont ();
  1698.     RETURN_TO_C (code);
  1699.   }
  1700. }
  1701.  
  1702. C_TO_SCHEME long
  1703. DEFUN_VOID (comp_cache_lookup_apply_restart)
  1704. {
  1705.   extern long Symbol_Lex_Ref();
  1706.   SCHEME_OBJECT name, environment, block;
  1707.   long code;
  1708.  
  1709.   name = (STACK_POP ());
  1710.   environment = (STACK_POP ());
  1711.   code = (Symbol_Lex_Ref (environment, name));
  1712.   if (code == PRIM_DONE)
  1713.   {
  1714.     /* Replace block with actual operator */
  1715.     (*(STACK_LOC (1))) = Val;
  1716.     if (COMPILED_CODE_ADDRESS_P (Val))
  1717.     {
  1718.       return (apply_compiled_procedure ());
  1719.     }
  1720.     else
  1721.     {
  1722.       return (PRIM_APPLY);
  1723.     }
  1724.   }
  1725.   else
  1726.   {
  1727.     STACK_PUSH (environment);
  1728.     STACK_PUSH (name);
  1729.     Store_Expression (SHARP_F);
  1730.     Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART);
  1731.     Save_Cont ();
  1732.     return (code);
  1733.   }
  1734. }
  1735.  
  1736. /* Variable reference traps:
  1737.    Reference to a free variable that has a reference trap -- either a
  1738.    fluid or an error (unassigned / unbound)
  1739.  */
  1740.  
  1741. #define CMPLR_REF_TRAP(name, c_trap, ret_code, restart, c_lookup)    \
  1742. SCHEME_UTILITY struct utility_result                    \
  1743. DEFUN (name,                                \
  1744.        (return_address, extension_addr, ignore_3, ignore_4),        \
  1745.        instruction *return_address AND                    \
  1746.        SCHEME_OBJECT *extension_addr AND                \
  1747.        long ignore_3 AND long ignore_4)                    \
  1748. {                                    \
  1749.   extern long c_trap();                            \
  1750.   long code;                                \
  1751.   SCHEME_OBJECT extension;                        \
  1752.                                     \
  1753.   extension = (MAKE_POINTER_OBJECT (TC_QUAD, extension_addr));        \
  1754.   code = c_trap (extension);                        \
  1755.   if (code == PRIM_DONE)                        \
  1756.   {                                    \
  1757.     RETURN_TO_SCHEME (return_address);                    \
  1758.   }                                    \
  1759.   else                                    \
  1760.   {                                    \
  1761.     SCHEME_OBJECT block, environment, name, sra;            \
  1762.                                     \
  1763.     sra = (ENTRY_TO_OBJECT (return_address));                \
  1764.     STACK_PUSH (sra);                            \
  1765.     block = (compiled_entry_to_block (sra));                \
  1766.     environment = (compiled_block_environment (block));            \
  1767.     STACK_PUSH (environment);                        \
  1768.     name = (compiler_var_error (extension, environment));        \
  1769.     STACK_PUSH (name);                            \
  1770.     Store_Expression (SHARP_F);                        \
  1771.     Store_Return (ret_code);                        \
  1772.     Save_Cont ();                            \
  1773.     RETURN_TO_C (code);                            \
  1774.   }                                    \
  1775. }                                    \
  1776.                                     \
  1777. C_TO_SCHEME long                            \
  1778. DEFUN_VOID (restart)                            \
  1779. {                                    \
  1780.   extern long c_lookup();                        \
  1781.   SCHEME_OBJECT name, environment;                    \
  1782.   long code;                                \
  1783.                                     \
  1784.   name = (Fetch_Expression ());                        \
  1785.   environment = (STACK_POP ());                        \
  1786.   code = (c_lookup (environment, name));                \
  1787.   if (code == PRIM_DONE)                        \
  1788.   {                                    \
  1789.     return (C_to_interface (OBJECT_ADDRESS (STACK_POP ())));        \
  1790.   }                                    \
  1791.   else                                    \
  1792.   {                                    \
  1793.     STACK_PUSH (environment);                        \
  1794.     STACK_PUSH (name);                            \
  1795.     Store_Expression (SHARP_F);                        \
  1796.     Store_Return (ret_code);                        \
  1797.     Save_Cont ();                            \
  1798.     return (code);                            \
  1799.   }                                    \
  1800. }
  1801.  
  1802. /* Actual traps */
  1803.  
  1804. CMPLR_REF_TRAP(comutil_lookup_trap,
  1805.                compiler_lookup_trap,
  1806.                RC_COMP_LOOKUP_TRAP_RESTART,
  1807.                comp_lookup_trap_restart,
  1808.                Symbol_Lex_Ref);
  1809.  
  1810. CMPLR_REF_TRAP(comutil_safe_lookup_trap,
  1811.                compiler_safe_lookup_trap,
  1812.                RC_COMP_SAFE_REF_TRAP_RESTART,
  1813.                comp_safe_lookup_trap_restart,
  1814.                safe_symbol_lex_ref);
  1815.  
  1816. CMPLR_REF_TRAP(comutil_unassigned_p_trap,
  1817.                compiler_unassigned_p_trap,
  1818.                RC_COMP_UNASSIGNED_TRAP_RESTART,
  1819.                comp_unassigned_p_trap_restart,
  1820.                Symbol_Lex_unassigned_p);
  1821.  
  1822. /* NUMERIC ROUTINES
  1823.    Invoke the arithmetic primitive in the fixed objects vector.
  1824.    The Scheme arguments are expected on the Scheme stack.
  1825.  */
  1826.  
  1827. #define COMPILER_ARITH_PRIM(name, fobj_index, arity)            \
  1828. SCHEME_UTILITY struct utility_result                    \
  1829. DEFUN (name,                                \
  1830.        (ignore_1, ignore_2, ignore_3, ignore_4),            \
  1831.        long ignore_1 AND long ignore_2 AND                \
  1832.        long ignore_3 AND long ignore_4)                    \
  1833. {                                    \
  1834.   SCHEME_OBJECT handler;                        \
  1835.                                     \
  1836.   handler = (Get_Fixed_Obj_Slot (fobj_index));                \
  1837.   return (comutil_apply (handler, (arity), 0, 0));            \
  1838. }
  1839.  
  1840. COMPILER_ARITH_PRIM (comutil_decrement, GENERIC_TRAMPOLINE_PREDECESSOR, 2);
  1841. COMPILER_ARITH_PRIM (comutil_divide, GENERIC_TRAMPOLINE_DIVIDE, 3);
  1842. COMPILER_ARITH_PRIM (comutil_equal, GENERIC_TRAMPOLINE_EQUAL_P, 3);
  1843. COMPILER_ARITH_PRIM (comutil_greater, GENERIC_TRAMPOLINE_GREATER_P, 3);
  1844. COMPILER_ARITH_PRIM (comutil_increment, GENERIC_TRAMPOLINE_SUCCESSOR, 2);
  1845. COMPILER_ARITH_PRIM (comutil_less, GENERIC_TRAMPOLINE_LESS_P, 3);
  1846. COMPILER_ARITH_PRIM (comutil_minus, GENERIC_TRAMPOLINE_SUBTRACT, 3);
  1847. COMPILER_ARITH_PRIM (comutil_modulo, GENERIC_TRAMPOLINE_MODULO, 3);
  1848. COMPILER_ARITH_PRIM (comutil_multiply, GENERIC_TRAMPOLINE_MULTIPLY, 3);
  1849. COMPILER_ARITH_PRIM (comutil_negative, GENERIC_TRAMPOLINE_NEGATIVE_P, 2);
  1850. COMPILER_ARITH_PRIM (comutil_plus, GENERIC_TRAMPOLINE_ADD, 3);
  1851. COMPILER_ARITH_PRIM (comutil_positive, GENERIC_TRAMPOLINE_POSITIVE_P, 2);
  1852. COMPILER_ARITH_PRIM (comutil_quotient, GENERIC_TRAMPOLINE_QUOTIENT, 3);
  1853. COMPILER_ARITH_PRIM (comutil_remainder, GENERIC_TRAMPOLINE_REMAINDER, 3);
  1854. COMPILER_ARITH_PRIM (comutil_zero, GENERIC_TRAMPOLINE_ZERO_P, 2);
  1855.  
  1856. /*
  1857.   Obsolete SCHEME_UTILITYs used to handle first class environments.
  1858.   They have been superseded by the variable caching code.
  1859.   They are here for completeness, and because the code in the compiler
  1860.   that uses them has not yet been spliced out, although it is switched
  1861.   off.
  1862. */
  1863.  
  1864. #define CMPLR_REFERENCE(util_name, c_proc, ret_code, restart_name)    \
  1865. SCHEME_UTILITY struct utility_result                    \
  1866. DEFUN (util_name,                            \
  1867.        (ret_add, environment, variable, ignore_4),            \
  1868.        instruction *ret_add AND                        \
  1869.        SCHEME_OBJECT environment AND SCHEME_OBJECT variable AND        \
  1870.        long ignore_4)                            \
  1871. {                                    \
  1872.   extern long c_proc();                            \
  1873.   long code;                                \
  1874.                                     \
  1875.   code = (c_proc (environment, variable));                \
  1876.   if (code == PRIM_DONE)                        \
  1877.   {                                    \
  1878.     RETURN_TO_SCHEME (ret_add);                        \
  1879.   }                                    \
  1880.   else                                    \
  1881.   {                                    \
  1882.     STACK_PUSH (ENTRY_TO_OBJECT (ret_add));                \
  1883.     STACK_PUSH (variable);                        \
  1884.     STACK_PUSH (environment);                        \
  1885.     Store_Expression (SHARP_F);                        \
  1886.     Store_Return (ret_code);                        \
  1887.     Save_Cont ();                            \
  1888.     RETURN_TO_C (code);                            \
  1889.   }                                    \
  1890. }                                    \
  1891.                                     \
  1892. C_TO_SCHEME long                            \
  1893. DEFUN_VOID (restart_name)                        \
  1894. {                                    \
  1895.   extern long c_proc();                            \
  1896.   SCHEME_OBJECT environment, variable;                    \
  1897.   long code;                                \
  1898.                                     \
  1899.   environment = (STACK_POP ());                        \
  1900.   variable = (STACK_POP ());                        \
  1901.   code = (c_proc (environment, variable));                \
  1902.   if (code == PRIM_DONE)                        \
  1903.   {                                    \
  1904.     Regs[REGBLOCK_ENV] = environment;                    \
  1905.     return (C_to_interface (OBJECT_ADDRESS (STACK_POP ())));        \
  1906.   }                                    \
  1907.   else                                    \
  1908.   {                                    \
  1909.     STACK_PUSH (variable);                        \
  1910.     STACK_PUSH (environment);                        \
  1911.     Store_Expression (SHARP_F);                        \
  1912.     Store_Return (ret_code);                        \
  1913.     Save_Cont ();                            \
  1914.     return (code);                            \
  1915.   }                                    \
  1916. }
  1917.  
  1918. #define CMPLR_ASSIGNMENT(util_name, c_proc, ret_code, restart_name)    \
  1919. SCHEME_UTILITY struct utility_result                    \
  1920. DEFUN (util_name,                            \
  1921.        (ret_add, environment, variable, value),                \
  1922.        instruction *ret_add AND                        \
  1923.        SCHEME_OBJECT environment AND SCHEME_OBJECT variable        \
  1924.        AND SCHEME_OBJECT value)                        \
  1925. {                                    \
  1926.   extern long c_proc();                            \
  1927.   long code;                                \
  1928.                                     \
  1929.   code = (c_proc (environment, variable, value));            \
  1930.   if (code == PRIM_DONE)                        \
  1931.   {                                    \
  1932.     RETURN_TO_SCHEME (ret_add);                        \
  1933.   }                                    \
  1934.   else                                    \
  1935.   {                                    \
  1936.     STACK_PUSH (ENTRY_TO_OBJECT (ret_add));                \
  1937.     STACK_PUSH (value);                            \
  1938.     STACK_PUSH (variable);                        \
  1939.     STACK_PUSH (environment);                        \
  1940.     Store_Expression (SHARP_F);                        \
  1941.     Store_Return (ret_code);                        \
  1942.     Save_Cont ();                            \
  1943.     RETURN_TO_C (code);                            \
  1944.   }                                    \
  1945. }                                    \
  1946.                                     \
  1947. C_TO_SCHEME long                            \
  1948. DEFUN_VOID (restart_name)                        \
  1949. {                                    \
  1950.   extern long c_proc();                            \
  1951.   SCHEME_OBJECT environment, variable, value;                \
  1952.   long code;                                \
  1953.                                     \
  1954.   environment = (Fetch_Expression ());                    \
  1955.   variable = (STACK_POP ());                        \
  1956.   value = (STACK_POP ());                        \
  1957.   code = (c_proc (environment, variable, value));            \
  1958.   if (code == PRIM_DONE)                        \
  1959.   {                                    \
  1960.     Regs[REGBLOCK_ENV] = environment;                    \
  1961.     return (C_to_interface (OBJECT_ADDRESS (STACK_POP ())));        \
  1962.   }                                    \
  1963.   else                                    \
  1964.   {                                    \
  1965.     STACK_PUSH (value);                            \
  1966.     STACK_PUSH (variable);                        \
  1967.     STACK_PUSH (environment);                        \
  1968.     Store_Expression (SHARP_F);                        \
  1969.     Store_Return (ret_code);                        \
  1970.     Save_Cont ();                            \
  1971.     return (code);                            \
  1972.   }                                    \
  1973. }
  1974.  
  1975. CMPLR_REFERENCE(comutil_access,
  1976.         Symbol_Lex_Ref,
  1977.         RC_COMP_ACCESS_RESTART,
  1978.         comp_access_restart);
  1979.  
  1980. CMPLR_REFERENCE(comutil_reference,
  1981.         Lex_Ref,
  1982.         RC_COMP_REFERENCE_RESTART,
  1983.         comp_reference_restart);
  1984.  
  1985. CMPLR_REFERENCE(comutil_safe_reference,
  1986.         safe_lex_ref,
  1987.         RC_COMP_SAFE_REFERENCE_RESTART,
  1988.         comp_safe_reference_restart);
  1989.  
  1990. CMPLR_REFERENCE(comutil_unassigned_p,
  1991.         Symbol_Lex_unassigned_p,
  1992.         RC_COMP_UNASSIGNED_P_RESTART,
  1993.         comp_unassigned_p_restart);
  1994.  
  1995. CMPLR_REFERENCE(comutil_unbound_p,
  1996.         Symbol_Lex_unbound_p,
  1997.         RC_COMP_UNBOUND_P_RESTART,
  1998.         comp_unbound_p_restart);
  1999.  
  2000. CMPLR_ASSIGNMENT(comutil_assignment,
  2001.          Lex_Set,
  2002.          RC_COMP_ASSIGNMENT_RESTART,
  2003.          comp_assignment_restart);
  2004.  
  2005. CMPLR_ASSIGNMENT(comutil_definition,
  2006.          Local_Set,
  2007.          RC_COMP_DEFINITION_RESTART,
  2008.          comp_definition_restart);
  2009.  
  2010. SCHEME_UTILITY struct utility_result
  2011. DEFUN (comutil_lookup_apply,
  2012.        (environment, variable, nactuals, ignore_4),
  2013.        SCHEME_OBJECT environment AND SCHEME_OBJECT variable AND
  2014.        long nactuals AND long ignore_4)
  2015. {
  2016.   extern long Lex_Ref();
  2017.   long code;
  2018.  
  2019.   code = (Lex_Ref (environment, variable));
  2020.   if (code == PRIM_DONE)
  2021.   {
  2022.     return (comutil_apply (Val, nactuals, 0, 0));
  2023.   }
  2024.   else
  2025.   {
  2026.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  2027.     STACK_PUSH (variable);
  2028.     STACK_PUSH (environment);
  2029.     Store_Expression (SHARP_F);
  2030.     Store_Return (RC_COMP_LOOKUP_APPLY_RESTART);
  2031.     Save_Cont ();
  2032.     RETURN_TO_C (code);
  2033.   }
  2034. }
  2035.  
  2036. C_TO_SCHEME long
  2037. DEFUN_VOID (comp_lookup_apply_restart)
  2038. {
  2039.   extern long Lex_Ref();
  2040.   SCHEME_OBJECT environment, variable;
  2041.   long code;
  2042.  
  2043.   environment = (STACK_POP ());
  2044.   variable = (STACK_POP ());
  2045.   code = (Lex_Ref (environment, variable));
  2046.   if (code == PRIM_DONE)
  2047.   {
  2048.     SCHEME_OBJECT nactuals;
  2049.  
  2050.     nactuals = (STACK_POP ());
  2051.     STACK_PUSH (Val);
  2052.     STACK_PUSH (nactuals);
  2053.     if (COMPILED_CODE_ADDRESS_P (Val))
  2054.     {
  2055.       return (apply_compiled_procedure ());
  2056.     }
  2057.     else
  2058.     {
  2059.       return (PRIM_APPLY);
  2060.     }
  2061.   }
  2062.   else
  2063.   {
  2064.     STACK_PUSH (variable);
  2065.     STACK_PUSH (environment);
  2066.     Store_Expression (SHARP_F);
  2067.     Store_Return (RC_COMP_LOOKUP_APPLY_RESTART);
  2068.     Save_Cont ();
  2069.     return (code);
  2070.   }
  2071. }
  2072.  
  2073. SCHEME_UTILITY struct utility_result
  2074. DEFUN (comutil_primitive_error,
  2075.        (ret_add, primitive, ignore_3, ignore_4),
  2076.        instruction *ret_add AND
  2077.        SCHEME_OBJECT primitive AND
  2078.        long ignore_3 AND long ignore_4)
  2079. {
  2080.   STACK_PUSH (ENTRY_TO_OBJECT (ret_add));
  2081.   STACK_PUSH (primitive);
  2082.   Store_Expression (SHARP_F);
  2083.   Store_Return (RC_COMP_ERROR_RESTART);
  2084.   Save_Cont ();
  2085.   RETURN_TO_C (ERR_COMPILED_CODE_ERROR);
  2086. }
  2087.  
  2088. C_TO_SCHEME long
  2089. DEFUN_VOID (comp_error_restart)
  2090. {
  2091.   instruction *ret_add;
  2092.  
  2093.   STACK_POP ();            /* primitive */
  2094.   ret_add = ((instruction *) (OBJECT_ADDRESS (STACK_POP ())));
  2095.   return (C_to_interface (ret_add));
  2096. }
  2097.  
  2098. /* Procedures to destructure compiled entries and closures. */
  2099.  
  2100. /*
  2101.   Extract the debugging information attached to `block'.  Usually
  2102.   this is a string which contains the filename where the debugging
  2103.   info is stored.
  2104.  */
  2105.  
  2106. C_UTILITY SCHEME_OBJECT
  2107. DEFUN (compiled_block_debugging_info,
  2108.        (block),
  2109.        SCHEME_OBJECT block)
  2110. {
  2111.   long length;
  2112.  
  2113.   length = (VECTOR_LENGTH (block));
  2114.   return (FAST_MEMORY_REF (block, (length - 1)));
  2115. }
  2116.  
  2117. /* Extract the environment where the `block' was "loaded". */
  2118.  
  2119. C_UTILITY SCHEME_OBJECT
  2120. DEFUN (compiled_block_environment,
  2121.        (block),
  2122.        SCHEME_OBJECT block)
  2123. {
  2124.   long length;
  2125.  
  2126.   length = (VECTOR_LENGTH (block));
  2127.   return (FAST_MEMORY_REF (block, length));
  2128. }
  2129.  
  2130. /*
  2131.   Given `entry', a Scheme object representing a compiled code entry point,
  2132.   it returns the address of the block to which it belongs.
  2133.  */
  2134.  
  2135. C_UTILITY SCHEME_OBJECT *
  2136. DEFUN (compiled_entry_to_block_address,
  2137.        (entry),
  2138.        SCHEME_OBJECT entry)
  2139. {
  2140.   SCHEME_OBJECT *block_address;
  2141.  
  2142.   Get_Compiled_Block (block_address, (OBJECT_ADDRESS (entry)));
  2143.   return (block_address);
  2144. }
  2145.  
  2146. C_UTILITY SCHEME_OBJECT
  2147. DEFUN (compiled_entry_to_block,
  2148.        (entry),
  2149.        SCHEME_OBJECT entry)
  2150. {
  2151.   SCHEME_OBJECT *block_address;
  2152.  
  2153.   Get_Compiled_Block (block_address, (OBJECT_ADDRESS (entry)));
  2154.   return (MAKE_CC_BLOCK (block_address));
  2155. }
  2156.  
  2157. /* Returns the offset from the block to the entry point. */
  2158.  
  2159. C_UTILITY long
  2160. DEFUN (compiled_entry_to_block_offset,
  2161.        (entry),
  2162.        SCHEME_OBJECT entry)
  2163. {
  2164.   SCHEME_OBJECT *entry_address, *block_address;
  2165.  
  2166.   entry_address = (OBJECT_ADDRESS (entry));
  2167.   Get_Compiled_Block (block_address, entry_address);
  2168.   return (((char *) entry_address) - ((char *) block_address));
  2169. }
  2170.  
  2171. /*
  2172.   Check whether the compiled code block whose address is `block_addr'
  2173.   is a compiled closure block.
  2174.  */
  2175.  
  2176. static long
  2177. DEFUN (block_address_closure_p,
  2178.        (block_addr),
  2179.        SCHEME_OBJECT *block_addr)
  2180. {
  2181.   SCHEME_OBJECT header_word;
  2182.  
  2183.   header_word = (*block_addr);
  2184.   return (((OBJECT_TYPE (header_word)) == TC_MANIFEST_CLOSURE));
  2185. }
  2186.  
  2187. /*
  2188.   Check whether the compiled code block `block' is a compiled closure block.
  2189.  */
  2190.  
  2191. C_UTILITY long
  2192. DEFUN (compiled_block_closure_p,
  2193.        (block),
  2194.        SCHEME_OBJECT block)
  2195. {
  2196.   return (block_address_closure_p (OBJECT_ADDRESS (block)));
  2197. }
  2198.  
  2199. /*
  2200.   Check whether the compiled entry point `entry' is a compiled closure.
  2201.  */
  2202.  
  2203. C_UTILITY long
  2204. DEFUN (compiled_entry_closure_p,
  2205.        (entry),
  2206.        SCHEME_OBJECT entry)
  2207. {
  2208.   return (block_address_closure_p (compiled_entry_to_block_address (entry)));
  2209. }
  2210.  
  2211. /*
  2212.   Extract the entry point ultimately invoked by the compiled closure
  2213.   represented by `entry'.
  2214.  */
  2215.  
  2216. C_UTILITY SCHEME_OBJECT
  2217. DEFUN (compiled_closure_to_entry,
  2218.        (entry),
  2219.        SCHEME_OBJECT entry)
  2220. {
  2221.   SCHEME_OBJECT real_entry;
  2222.  
  2223.   EXTRACT_CLOSURE_ENTRY_ADDRESS (real_entry, (OBJECT_ADDRESS (entry)));
  2224.   return (ENTRY_TO_OBJECT (real_entry));
  2225. }
  2226.  
  2227. /*
  2228.   Store the information for `entry' into `buffer'.
  2229.   This is used by the printer and debugging utilities.
  2230.  */
  2231.  
  2232. /* Kinds and subkinds of entries. */
  2233.  
  2234. #define KIND_PROCEDURE                          0
  2235. #define KIND_CONTINUATION                       1
  2236. #define KIND_EXPRESSION                         2
  2237. #define KIND_OTHER                              3
  2238. #define KIND_ILLEGAL                            4
  2239.  
  2240. /* Continuation subtypes */
  2241.  
  2242. #define CONTINUATION_NORMAL                     0
  2243. #define CONTINUATION_DYNAMIC_LINK               1
  2244. #define CONTINUATION_RETURN_TO_INTERPRETER      2
  2245.  
  2246. C_UTILITY void
  2247. DEFUN (compiled_entry_type,
  2248.        (entry, buffer),
  2249.        SCHEME_OBJECT entry AND
  2250.        long *buffer)
  2251. {
  2252.   long kind, min_arity, max_arity, field1, field2;
  2253.   SCHEME_OBJECT *entry_address;
  2254.  
  2255.   entry_address = (OBJECT_ADDRESS (entry));
  2256.   max_arity = (COMPILED_ENTRY_MAXIMUM_ARITY (entry_address));
  2257.   min_arity = (COMPILED_ENTRY_MINIMUM_ARITY (entry_address));
  2258.   field1 = min_arity;
  2259.   field2 = max_arity;
  2260.   if (min_arity >= 0)
  2261.   {
  2262.     kind = KIND_PROCEDURE;
  2263.   }
  2264.   else if (max_arity >= 0)
  2265.   {
  2266.     kind = KIND_ILLEGAL;
  2267.   }
  2268.   else if ((((unsigned long) max_arity) & 0xff) < 0xe0)
  2269.   {
  2270.     /* Field2 is the offset to the next continuation */
  2271.  
  2272.     kind = KIND_CONTINUATION;
  2273.     field1 = CONTINUATION_NORMAL;
  2274.     field2 = (((((unsigned long) max_arity) & 0x3f) << 7) |
  2275.               (((unsigned long) min_arity) & 0x7f));
  2276.   }
  2277.   else if (min_arity != (-1))
  2278.   {
  2279.     kind = KIND_ILLEGAL;
  2280.   }
  2281.   else
  2282.   {
  2283.     switch (((unsigned long) max_arity) & 0xff)
  2284.     {
  2285.       case FORMAT_BYTE_EXPR:
  2286.       {
  2287.         kind = KIND_EXPRESSION;
  2288.         break;
  2289.       }
  2290.       case FORMAT_BYTE_COMPLR:
  2291.       case FORMAT_BYTE_CMPINT:
  2292.       {
  2293.         kind = KIND_OTHER;
  2294.         break;
  2295.       }
  2296.       case FORMAT_BYTE_DLINK:
  2297.       {
  2298.         kind = KIND_CONTINUATION;
  2299.         field1 = CONTINUATION_DYNAMIC_LINK;
  2300.         field2 = -1;
  2301.         break;
  2302.       }
  2303.       case FORMAT_BYTE_RETURN:
  2304.       {
  2305.         kind = KIND_CONTINUATION;
  2306.         field1 = CONTINUATION_RETURN_TO_INTERPRETER;
  2307.         field2 = 0;
  2308.         break;
  2309.       }
  2310.       default:
  2311.       {
  2312.         kind = KIND_ILLEGAL;
  2313.         break;
  2314.       }
  2315.     }
  2316.   }
  2317.   buffer[0] = kind;
  2318.   buffer[1] = field1;
  2319.   buffer[2] = field2;
  2320.   return;
  2321. }
  2322.  
  2323. /* Destructuring free variable caches. */
  2324.  
  2325. C_UTILITY void
  2326. DEFUN (store_variable_cache,
  2327.        (extension, block, offset),
  2328.        SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
  2329.        long offset)
  2330. {
  2331.   FAST_MEMORY_SET (block, offset,
  2332.                    ((SCHEME_OBJECT) (OBJECT_ADDRESS (extension))));
  2333.   return;
  2334. }
  2335.  
  2336. C_UTILITY SCHEME_OBJECT
  2337. DEFUN (extract_variable_cache,
  2338.        (block, offset),
  2339.        SCHEME_OBJECT block AND
  2340.        long offset)
  2341. {
  2342.   return (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE,
  2343.                                ((SCHEME_OBJECT *)
  2344.                                 (FAST_MEMORY_REF (block, offset)))));
  2345. }
  2346.  
  2347. /* Get a compiled procedure from a cached operator reference. */
  2348.  
  2349. C_UTILITY SCHEME_OBJECT
  2350. DEFUN (extract_uuo_link,
  2351.        (block, offset),
  2352.        SCHEME_OBJECT block AND
  2353.        long offset)
  2354. {
  2355.   SCHEME_OBJECT *cache_address, compiled_entry_address;
  2356.  
  2357.   cache_address = (MEMORY_LOC (block, offset));
  2358.   EXTRACT_EXECUTE_CACHE_ADDRESS (compiled_entry_address, cache_address);
  2359.   return (ENTRY_TO_OBJECT (compiled_entry_address));
  2360. }
  2361.  
  2362. static void
  2363. DEFUN (store_uuo_link,
  2364.        (entry, cache_address),
  2365.        SCHEME_OBJECT entry AND SCHEME_OBJECT *cache_address)
  2366. {
  2367.   SCHEME_OBJECT *entry_address;
  2368.  
  2369.   entry_address = (OBJECT_ADDRESS (entry));
  2370.   STORE_EXECUTE_CACHE_CODE (cache_address);
  2371.   STORE_EXECUTE_CACHE_ADDRESS (cache_address, entry_address);
  2372.   if (!linking_cc_block_p)
  2373.   {
  2374.     /* The linker will flush the whole region afterwards. */
  2375.  
  2376.     FLUSH_I_CACHE_REGION (cache_address, EXECUTE_CACHE_ENTRY_SIZE);
  2377.   }
  2378.   return;
  2379. }
  2380.  
  2381. /* This makes a fake compiled procedure which traps to kind handler when
  2382.    invoked.
  2383.  */
  2384.  
  2385. #define TRAMPOLINE_SIZE    (TRAMPOLINE_ENTRY_SIZE + 2)
  2386.  
  2387. static long
  2388. DEFUN (make_trampoline,
  2389.        (slot, fmt_word, kind, size, value1, value2, value3),
  2390.        SCHEME_OBJECT *slot AND
  2391.        format_word fmt_word AND
  2392.        long kind AND long size AND
  2393.        SCHEME_OBJECT value1 AND SCHEME_OBJECT value2
  2394.        AND SCHEME_OBJECT value3)
  2395. {
  2396.   SCHEME_OBJECT * block, * local_free;
  2397.   instruction * entry_point;
  2398.  
  2399.   if (GC_Check (TRAMPOLINE_SIZE + size))
  2400.   {
  2401.     Request_GC (TRAMPOLINE_SIZE + size);
  2402.     return (PRIM_INTERRUPT);
  2403.   }
  2404.  
  2405.   local_free = Free;
  2406.   Free += (TRAMPOLINE_SIZE + size);
  2407.   block = local_free;
  2408.   local_free[0] = (MAKE_OBJECT (TC_MANIFEST_VECTOR,
  2409.                 ((TRAMPOLINE_SIZE - 1) + size)));
  2410.   local_free[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
  2411.                 TRAMPOLINE_ENTRY_SIZE));
  2412.   entry_point = ((instruction *) (TRAMPOLINE_ENTRY_POINT (local_free)));
  2413.   local_free = (TRAMPOLINE_STORAGE (entry_point));
  2414.   (COMPILED_ENTRY_FORMAT_WORD (entry_point)) = fmt_word;
  2415.   (COMPILED_ENTRY_OFFSET_WORD (entry_point)) =
  2416.     (MAKE_OFFSET_WORD (entry_point, block, false));
  2417.   STORE_TRAMPOLINE_ENTRY (entry_point, kind);
  2418.  
  2419.   if ((--size) >= 0)
  2420.     *local_free++ = value1;
  2421.   if ((--size) >= 0)
  2422.     *local_free++ = value2;
  2423.   if ((--size) >= 0)
  2424.     *local_free++ = value3;
  2425.   *slot = (ENTRY_TO_OBJECT (entry_point));
  2426.   return (PRIM_DONE);
  2427. }
  2428.  
  2429. /* Standard trampolines. */
  2430.  
  2431. static long
  2432. DEFUN (make_redirection_trampoline,
  2433.        (slot, kind, procedure),
  2434.        SCHEME_OBJECT *slot AND
  2435.        long kind AND
  2436.        SCHEME_OBJECT procedure)
  2437. {
  2438.   return (make_trampoline (slot,
  2439.                ((format_word) FORMAT_WORD_CMPINT),
  2440.                kind,
  2441.                1,
  2442.                procedure,
  2443.                SHARP_F,
  2444.                SHARP_F));
  2445. }
  2446.  
  2447. static long
  2448. DEFUN (make_apply_trampoline,
  2449.        (slot, kind, procedure, nactuals),
  2450.        SCHEME_OBJECT *slot AND
  2451.        long kind AND SCHEME_OBJECT procedure AND
  2452.        long nactuals)
  2453. {
  2454.   return (make_trampoline (slot,
  2455.                ((format_word) FORMAT_WORD_CMPINT),
  2456.                kind,
  2457.                2,
  2458.                procedure,
  2459.                (LONG_TO_UNSIGNED_FIXNUM (nactuals)),
  2460.                SHARP_F));
  2461. }
  2462.  
  2463. #define TRAMPOLINE_TABLE_SIZE   4
  2464.  
  2465. static long
  2466. trampoline_arity_table[TRAMPOLINE_TABLE_SIZE * TRAMPOLINE_TABLE_SIZE] =
  2467. {
  2468.   TRAMPOLINE_K_1_0,        /* 1_0 */
  2469.   TRAMPOLINE_K_ARITY,        /* 1_1 should not get here */
  2470.   TRAMPOLINE_K_ARITY,        /* 1_2 should not get here */
  2471.   TRAMPOLINE_K_ARITY,        /* 1_3 should not get here */
  2472.   TRAMPOLINE_K_2_0,        /* 2_0 */
  2473.   TRAMPOLINE_K_2_1,        /* 2_1 */
  2474.   TRAMPOLINE_K_ARITY,        /* 2_2 should not get here */
  2475.   TRAMPOLINE_K_ARITY,        /* 2_3 should not get here */
  2476.   TRAMPOLINE_K_3_0,        /* 3_0 */
  2477.   TRAMPOLINE_K_3_1,        /* 3_1 */
  2478.   TRAMPOLINE_K_3_2,        /* 3_2 */
  2479.   TRAMPOLINE_K_ARITY,        /* 3_3 should not get here */
  2480.   TRAMPOLINE_K_4_0,        /* 4_0 */
  2481.   TRAMPOLINE_K_4_1,        /* 4_1 */
  2482.   TRAMPOLINE_K_4_2,        /* 4_2 */
  2483.   TRAMPOLINE_K_4_3        /* 4_3 */
  2484. };
  2485.  
  2486. /*
  2487.   make_uuo_link is called by C and initializes a compiled procedure
  2488.   cache at a location given by a block and an offset.
  2489.  
  2490.   make_uuo_link checks its procedure argument, and:
  2491.  
  2492.   - If it is not a compiled procedure, an entity, or a primitive
  2493.   procedure with a matching number of arguments, it stores a fake
  2494.   compiled procedure which will invoke comutil_operator_interpreted_trap
  2495.   when invoked.
  2496.  
  2497.   - If its argument is an entity, it stores a fake compiled procedure
  2498.   which will invoke comutil_operator_entity_trap when invoked.
  2499.  
  2500.   - If its argument is a primitive, it stores a fake compiled procedure
  2501.   which will invoke comutil_operator_primitive_trap, or
  2502.   comutil_operator_lexpr_trap when invoked.
  2503.  
  2504.   - If its argument is a compiled procedure that expects more or
  2505.   less arguments than those provided, it stores a fake compiled
  2506.   procedure which will invoke comutil_operator_arity_trap, or one of
  2507.   its specialized versions when invoked.
  2508.  
  2509.   - Otherwise, the actual (compatible) operator is stored.
  2510. */
  2511.  
  2512. C_UTILITY long
  2513. DEFUN (make_uuo_link,
  2514.        (procedure, extension, block, offset),
  2515.        SCHEME_OBJECT procedure AND SCHEME_OBJECT extension
  2516.        AND SCHEME_OBJECT block AND
  2517.        long offset)
  2518. {
  2519.   long kind, result, nactuals;
  2520.   SCHEME_OBJECT orig_proc, trampoline, *cache_address;
  2521.  
  2522.   cache_address = (MEMORY_LOC (block, offset));
  2523.   EXTRACT_EXECUTE_CACHE_ARITY (nactuals, cache_address);
  2524.   /* nactuals >= 0 */
  2525.  
  2526.   orig_proc = procedure;
  2527. loop:
  2528.   switch (OBJECT_TYPE (procedure))
  2529.   {
  2530.     case TC_COMPILED_ENTRY:
  2531.     {
  2532.       SCHEME_OBJECT *entry;
  2533.       long nmin, nmax;
  2534.  
  2535.       entry = (OBJECT_ADDRESS (procedure));
  2536.       nmax = (COMPILED_ENTRY_MAXIMUM_ARITY (entry));
  2537.       if (nactuals == nmax)
  2538.       {
  2539.         store_uuo_link (procedure, cache_address);
  2540.         return (PRIM_DONE);
  2541.       }
  2542.       nmin = (COMPILED_ENTRY_MINIMUM_ARITY (entry));
  2543.       if ((nmax > 1) && (nmin > 0) && (nmin <= nactuals) &&
  2544.           (nactuals <= TRAMPOLINE_TABLE_SIZE) &&
  2545.           (nmax <= (TRAMPOLINE_TABLE_SIZE + 1)))
  2546.       {
  2547.         kind = (trampoline_arity_table[((nmax - 2) * TRAMPOLINE_TABLE_SIZE) +
  2548.                        (nactuals - 1)]);
  2549.     /* Paranoia */
  2550.     if (kind != TRAMPOLINE_K_ARITY)
  2551.     {
  2552.       nactuals = 0;
  2553.       break;
  2554.     }
  2555.       }
  2556.       kind = TRAMPOLINE_K_ARITY;
  2557.       break;
  2558.     }
  2559.  
  2560.     case TC_ENTITY:
  2561.     {
  2562.       SCHEME_OBJECT data, tag, handler;
  2563.  
  2564.       data = (MEMORY_REF (procedure, ENTITY_DATA));
  2565.       if ((VECTOR_P (data))
  2566.       && (nactuals < (VECTOR_LENGTH (data)))
  2567.       && ((VECTOR_REF (data, nactuals)) != SHARP_F)
  2568.       && ((VECTOR_REF (data, 0))
  2569.           == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG))))
  2570.       {
  2571.     if (procedure == orig_proc)
  2572.     {
  2573.       procedure = (VECTOR_REF (data, nactuals));
  2574.       goto loop;
  2575.     }
  2576.     else
  2577.     {
  2578.       /* No loops allowed! */
  2579.       procedure = orig_proc;
  2580.     }
  2581.       }
  2582.       kind = TRAMPOLINE_K_ENTITY;
  2583.       break;
  2584.     }
  2585.  
  2586.     case TC_PRIMITIVE:
  2587.     {
  2588.       long arity;
  2589.       extern long primitive_to_arity ();
  2590.  
  2591.       arity = primitive_to_arity (procedure);
  2592.       if (arity == (nactuals - 1))
  2593.       {
  2594.     nactuals = 0;
  2595.         kind = TRAMPOLINE_K_PRIMITIVE;
  2596.       }
  2597.       else if (arity == LEXPR_PRIMITIVE_ARITY)
  2598.       {
  2599.         kind = TRAMPOLINE_K_LEXPR_PRIMITIVE;
  2600.       }
  2601.       else
  2602.       {
  2603.         kind = TRAMPOLINE_K_OTHER;
  2604.       }
  2605.       break;
  2606.     }
  2607.  
  2608.     case TC_PROCEDURE: /* and some others... */
  2609.     default:
  2610.     uuo_link_interpreted:
  2611.     {
  2612.       kind = TRAMPOLINE_K_INTERPRETED;
  2613.       break;
  2614.     }
  2615.   }
  2616.   if (nactuals == 0)
  2617.   {
  2618.     result = (make_redirection_trampoline (&trampoline, kind, procedure));
  2619.   }
  2620.   else
  2621.   {
  2622.     result = (make_apply_trampoline (&trampoline, kind, procedure, nactuals));
  2623.   }
  2624.   if (result != PRIM_DONE)
  2625.   {
  2626.     return (result);
  2627.   }
  2628.   store_uuo_link (trampoline, cache_address);
  2629.   return (PRIM_DONE);
  2630. }
  2631.  
  2632. C_UTILITY long
  2633. DEFUN (make_fake_uuo_link,
  2634.        (extension, block, offset),
  2635.        SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
  2636.        long offset)
  2637. {
  2638.   long result;
  2639.   SCHEME_OBJECT trampoline, *cache_address;
  2640.  
  2641.   result = (make_trampoline (&trampoline,
  2642.                  ((format_word) FORMAT_WORD_CMPINT),
  2643.                  TRAMPOLINE_K_LOOKUP,
  2644.                  3,
  2645.                  extension,
  2646.                  block,
  2647.                  (LONG_TO_UNSIGNED_FIXNUM (offset))));
  2648.   if (result != PRIM_DONE)
  2649.   {
  2650.     return (result);
  2651.   }
  2652.   cache_address = (MEMORY_LOC (block, offset));
  2653.   store_uuo_link (trampoline, cache_address);
  2654.   return (PRIM_DONE);
  2655. }
  2656.  
  2657. /* C_UTILITY long fake_uuo_link_p does not appear to be used anymore */
  2658.  
  2659. C_UTILITY long
  2660. DEFUN (coerce_to_compiled,
  2661.        (procedure, arity, location),
  2662.        SCHEME_OBJECT procedure AND long arity AND SCHEME_OBJECT *location)
  2663. {
  2664.   long frame_size;
  2665.  
  2666.   frame_size = (arity + 1);
  2667.   if ((!(COMPILED_CODE_ADDRESS_P (procedure))) ||
  2668.       ((COMPILED_ENTRY_MAXIMUM_ARITY (OBJECT_ADDRESS (procedure))) !=
  2669.        frame_size))
  2670.   {
  2671.     if (frame_size > FORMAT_BYTE_FRAMEMAX)
  2672.     {
  2673.       return (ERR_WRONG_NUMBER_OF_ARGUMENTS);
  2674.     }
  2675.     return (make_trampoline (location,
  2676.                  ((format_word)
  2677.                   (MAKE_FORMAT_WORD (frame_size, frame_size))),
  2678.                  TRAMPOLINE_K_APPLY,
  2679.                  2,
  2680.                  procedure,
  2681.                  (LONG_TO_UNSIGNED_FIXNUM (frame_size)),
  2682.                  SHARP_F));
  2683.   }
  2684.   (*location) = procedure;
  2685.   return (PRIM_DONE);
  2686. }
  2687.  
  2688. /* Initialization */
  2689.  
  2690. #define COMPILER_INTERFACE_VERSION        3
  2691.  
  2692. #ifndef COMPILER_REGBLOCK_N_FIXED
  2693. #  define COMPILER_REGBLOCK_N_FIXED        16
  2694. #endif
  2695.  
  2696. #ifndef COMPILER_REGBLOCK_N_TEMPS
  2697. #  define COMPILER_REGBLOCK_N_TEMPS        256
  2698. #endif
  2699.  
  2700. #ifndef COMPILER_REGBLOCK_EXTRA_SIZE
  2701. #  define COMPILER_REGBLOCK_EXTRA_SIZE        0
  2702. #endif
  2703.  
  2704. #if (REGBLOCK_MINIMUM_LENGTH > COMPILER_REGBLOCK_N_FIXED)
  2705. #  include "ERROR: cmpint.c and const.h disagree on REGBLOCK_MINIMUM_LENGTH!"
  2706. #endif
  2707.  
  2708. /* ((sizeof(SCHEME_OBJECT)) / (sizeof(SCHEME_OBJECT))) */
  2709.  
  2710. #define COMPILER_FIXED_SIZE    1
  2711.  
  2712. #ifndef COMPILER_TEMP_SIZE
  2713. #  define COMPILER_TEMP_SIZE    ((sizeof (double)) / (sizeof (SCHEME_OBJECT)))
  2714. #endif
  2715.  
  2716. #define REGBLOCK_LENGTH                            \
  2717.   ((COMPILER_REGBLOCK_N_FIXED * COMPILER_FIXED_SIZE) +            \
  2718.    (COMPILER_REGBLOCK_N_TEMPS * COMPILER_TEMP_SIZE) +            \
  2719.    COMPILER_REGBLOCK_EXTRA_SIZE)
  2720.  
  2721. #ifndef ASM_RESET_HOOK
  2722. #  define ASM_RESET_HOOK() NOP()
  2723. #endif
  2724.  
  2725. long
  2726.   compiler_processor_type,
  2727.   compiler_interface_version;
  2728.  
  2729. SCHEME_OBJECT
  2730.   compiler_utilities,
  2731.   return_to_interpreter;
  2732.  
  2733. #ifndef REGBLOCK_ALLOCATED_BY_INTERFACE
  2734. SCHEME_OBJECT
  2735.   Registers[REGBLOCK_LENGTH];
  2736. #endif
  2737.  
  2738. static void
  2739. DEFUN_VOID (compiler_reset_internal)
  2740. {
  2741.   /* Other stuff can be placed here. */
  2742.  
  2743.   Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) NULL);
  2744.   Registers[REGBLOCK_CLOSURE_SPACE] = ((SCHEME_OBJECT) 0);
  2745.  
  2746.   ASM_RESET_HOOK();
  2747.  
  2748.   return_to_interpreter =
  2749.     (ENTRY_TO_OBJECT (TRAMPOLINE_ENTRY_POINT
  2750.               (OBJECT_ADDRESS (compiler_utilities))));
  2751.  
  2752.   return;
  2753. }
  2754.  
  2755. C_UTILITY void
  2756. DEFUN (compiler_reset,
  2757.        (new_block),
  2758.        SCHEME_OBJECT new_block)
  2759. {
  2760.   /* Called after a disk restore */
  2761.  
  2762.   if ((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK)
  2763.   {
  2764.     extern void compiler_reset_error ();
  2765.  
  2766.     compiler_reset_error ();
  2767.   }
  2768.   else
  2769.   {
  2770.     compiler_utilities = new_block;
  2771.     compiler_reset_internal ();
  2772.   }
  2773.   return;
  2774. }
  2775.  
  2776. C_UTILITY void
  2777. DEFUN (compiler_initialize,
  2778.        (fasl_p),
  2779.        long fasl_p)
  2780. {
  2781.   /* Start-up of whole interpreter */
  2782.  
  2783.   long code;
  2784.   SCHEME_OBJECT trampoline, *block;
  2785.  
  2786.   compiler_processor_type = COMPILER_PROCESSOR_TYPE;
  2787.   compiler_interface_version = COMPILER_INTERFACE_VERSION;
  2788.   if (fasl_p)
  2789.   {
  2790.     extern SCHEME_OBJECT *copy_to_constant_space();
  2791.  
  2792.     code = (make_trampoline (&trampoline,
  2793.                  ((format_word) FORMAT_WORD_RETURN),
  2794.                  TRAMPOLINE_K_RETURN,
  2795.                  0, SHARP_F, SHARP_F, SHARP_F));
  2796.     if (code != PRIM_DONE)
  2797.     {
  2798.       fprintf (stderr,
  2799.            "compiler_initialize: Not enough space!\n");
  2800.       Microcode_Termination (TERM_NO_SPACE);
  2801.     }
  2802.     block = (compiled_entry_to_block_address (trampoline));
  2803.     block = (copy_to_constant_space (block, (1 + (OBJECT_DATUM (block[0])))));
  2804.     compiler_utilities = (MAKE_CC_BLOCK (block));
  2805.     compiler_reset_internal ();
  2806.   }
  2807.   else
  2808.   {
  2809.     /* Delay until after band-load, when compiler_reset will be invoked. */
  2810.     compiler_utilities = SHARP_F;
  2811.     return_to_interpreter = SHARP_F;
  2812. #ifdef sonyrisc
  2813.     /* On the Sony NEWS 3250, this procedure initializes the
  2814.        floating-point CPU control register to enable the IEEE traps.
  2815.        This is normally executed by `compiler_reset' from LOAD-BAND,
  2816.        but the Sony operating system saves the control register in
  2817.        `setjmp' and restores it on `longjmp', so we must initialize
  2818.        the register before `setjmp' is called.  */
  2819.     interface_initialize ();
  2820. #endif
  2821.   }
  2822.   return;
  2823. }
  2824.  
  2825. #else    /* not HAS_COMPILER_SUPPORT */
  2826.  
  2827. /* Stubs for compiler utilities.
  2828.    All entries error out or kill the microcode.
  2829.  */
  2830.  
  2831. #include "ansidecl.h"    /* Macros to support ANSI declarations */
  2832. #include "config.h"    /* Machine configurations */
  2833. #include "object.h"    /* Making pointers */
  2834. #include "sdata.h"    /* Needed by const.h */
  2835. #include "types.h"    /* Needed by const.h */
  2836. #include "errors.h"    /* Error codes and Termination codes */
  2837. #include "const.h"    /* REGBLOCK_MINIMUM_LENGTH */
  2838. #include "returns.h"    /* RC_POP_FROM_COMPILED_CODE */
  2839.  
  2840. extern void EXFUN (Microcode_Termination, (int code));
  2841. extern void EXFUN (compiler_reset_error, (void));
  2842.  
  2843. extern long
  2844.   compiler_interface_version,
  2845.   compiler_processor_type;
  2846.  
  2847. extern SCHEME_OBJECT
  2848.   Registers[],
  2849.   compiler_utilities,
  2850.   return_to_interpreter;
  2851.  
  2852. extern long
  2853.   EXFUN (enter_compiled_expression, (void)),
  2854.   EXFUN (apply_compiled_procedure, (void)),
  2855.   EXFUN (return_to_compiled_code, (void)),
  2856.   EXFUN (make_fake_uuo_link,
  2857.      (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
  2858.   EXFUN (make_uuo_link,
  2859.      (SCHEME_OBJECT value, SCHEME_OBJECT extension,
  2860.       SCHEME_OBJECT block, long offset)),
  2861.   EXFUN (compiled_block_closure_p, (SCHEME_OBJECT block)),
  2862.   EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT entry)),
  2863.   EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT entry)),
  2864.   EXFUN (coerce_to_compiled,
  2865.      (SCHEME_OBJECT object, long arity, SCHEME_OBJECT *location));
  2866.  
  2867. extern SCHEME_OBJECT
  2868.   EXFUN (extract_uuo_link, (SCHEME_OBJECT block, long offset)),
  2869.   EXFUN (extract_variable_cache,
  2870.      (SCHEME_OBJECT extension, long offset)),
  2871.   EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT block)),
  2872.   EXFUN (compiled_block_environment, (SCHEME_OBJECT block)),
  2873.   EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)),
  2874.   * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT entry)),
  2875.   EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry));
  2876.  
  2877. extern void
  2878.   EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
  2879.   EXFUN (compiler_initialize, (long fasl_p)),
  2880.   EXFUN (store_variable_cache,
  2881.      (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
  2882.   EXFUN (compiled_entry_type,
  2883.      (SCHEME_OBJECT entry, long *buffer));
  2884.  
  2885. SCHEME_OBJECT
  2886.   Registers[REGBLOCK_MINIMUM_LENGTH],
  2887.   compiler_utilities,
  2888.   return_to_interpreter;
  2889.  
  2890. long
  2891.   compiler_interface_version,
  2892.   compiler_processor_type;
  2893.  
  2894. long
  2895. DEFUN_VOID (enter_compiled_expression)
  2896. {
  2897.   return (ERR_EXECUTE_MANIFEST_VECTOR);
  2898. }
  2899.  
  2900. long
  2901. DEFUN_VOID (apply_compiled_procedure)
  2902. {
  2903.   return (ERR_INAPPLICABLE_OBJECT);
  2904. }
  2905.  
  2906. long
  2907. DEFUN_VOID (return_to_compiled_code)
  2908. {
  2909.   return (ERR_INAPPLICABLE_CONTINUATION);
  2910. }
  2911.  
  2912. /* Bad entry points. */
  2913.  
  2914. long
  2915. DEFUN (make_fake_uuo_link,
  2916.        (extension, block, offset),
  2917.        SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
  2918.        long offset)
  2919. {
  2920.   Microcode_Termination (TERM_COMPILER_DEATH);
  2921.   /*NOTREACHED*/
  2922. }
  2923.  
  2924. long
  2925. DEFUN (make_uuo_link,
  2926.        (value, extension, block, offset),
  2927.        SCHEME_OBJECT value AND SCHEME_OBJECT extension AND
  2928.        SCHEME_OBJECT block AND long offset)
  2929. {
  2930.   Microcode_Termination (TERM_COMPILER_DEATH);
  2931.   /*NOTREACHED*/
  2932. }
  2933.  
  2934. SCHEME_OBJECT
  2935. DEFUN (extract_uuo_link,
  2936.        (block, offset),
  2937.        SCHEME_OBJECT block AND long offset)
  2938. {
  2939.   Microcode_Termination (TERM_COMPILER_DEATH);
  2940.   /*NOTREACHED*/
  2941. }
  2942.  
  2943. void
  2944. DEFUN (store_variable_cache,
  2945.        (extension, block, offset),
  2946.        SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
  2947.        long offset)
  2948. {
  2949.   Microcode_Termination (TERM_COMPILER_DEATH);
  2950.   /*NOTREACHED*/
  2951. }
  2952.  
  2953. SCHEME_OBJECT
  2954. DEFUN (extract_variable_cache,
  2955.        (block, offset),
  2956.        SCHEME_OBJECT block AND
  2957.        long offset)
  2958. {
  2959.   Microcode_Termination (TERM_COMPILER_DEATH);
  2960.   /*NOTREACHED*/
  2961. }
  2962.  
  2963. SCHEME_OBJECT
  2964. DEFUN (compiled_block_debugging_info,
  2965.        (block),
  2966.        SCHEME_OBJECT block)
  2967. {
  2968.   Microcode_Termination (TERM_COMPILER_DEATH);
  2969.   /*NOTREACHED*/
  2970. }
  2971.  
  2972. SCHEME_OBJECT
  2973. DEFUN (compiled_block_environment,
  2974.        (block),
  2975.        SCHEME_OBJECT block)
  2976. {
  2977.   Microcode_Termination (TERM_COMPILER_DEATH);
  2978.   /*NOTREACHED*/
  2979. }
  2980.  
  2981. long
  2982. DEFUN (compiled_block_closure_p,
  2983.        (block),
  2984.        SCHEME_OBJECT block)
  2985. {
  2986.   Microcode_Termination (TERM_COMPILER_DEATH);
  2987.   /*NOTREACHED*/
  2988. }
  2989.  
  2990. SCHEME_OBJECT *
  2991. DEFUN (compiled_entry_to_block_address,
  2992.        (entry),
  2993.        SCHEME_OBJECT entry)
  2994. {
  2995.   Microcode_Termination (TERM_COMPILER_DEATH);
  2996.   /*NOTREACHED*/
  2997. }
  2998.  
  2999. long
  3000. DEFUN (compiled_entry_to_block_offset,
  3001.        (entry),
  3002.        SCHEME_OBJECT entry)
  3003. {
  3004.   Microcode_Termination (TERM_COMPILER_DEATH);
  3005.   /*NOTREACHED*/
  3006. }
  3007.  
  3008. SCHEME_OBJECT
  3009. DEFUN (compiled_entry_to_block,
  3010.        (entry),
  3011.        SCHEME_OBJECT entry)
  3012. {
  3013.   Microcode_Termination (TERM_COMPILER_DEATH);
  3014.   /*NOTREACHED*/
  3015. }
  3016.  
  3017.  
  3018. void
  3019. DEFUN (compiled_entry_type,
  3020.        (entry, buffer),
  3021.        SCHEME_OBJECT entry AND long *buffer)
  3022. {
  3023.   Microcode_Termination (TERM_COMPILER_DEATH);
  3024.   /*NOTREACHED*/
  3025. }
  3026.  
  3027. long
  3028. DEFUN (compiled_entry_closure_p,
  3029.        (entry),
  3030.        SCHEME_OBJECT entry)
  3031. {
  3032.   Microcode_Termination (TERM_COMPILER_DEATH);
  3033.   /*NOTREACHED*/
  3034. }
  3035.  
  3036. SCHEME_OBJECT
  3037. DEFUN (compiled_closure_to_entry,
  3038.        (entry),
  3039.        SCHEME_OBJECT entry)
  3040. {
  3041.   Microcode_Termination (TERM_COMPILER_DEATH);
  3042.   /*NOTREACHED*/
  3043. }
  3044.  
  3045. #define LOSING_RETURN_ADDRESS(name)                    \
  3046. extern long EXFUN (name, (void));                    \
  3047. long                                    \
  3048. DEFUN_VOID (name)                            \
  3049. {                                    \
  3050.   Microcode_Termination (TERM_COMPILER_DEATH);                \
  3051.   /*NOTREACHED*/                            \
  3052. }
  3053.  
  3054. LOSING_RETURN_ADDRESS (comp_interrupt_restart)
  3055. LOSING_RETURN_ADDRESS (comp_lookup_apply_restart)
  3056. LOSING_RETURN_ADDRESS (comp_reference_restart)
  3057. LOSING_RETURN_ADDRESS (comp_access_restart)
  3058. LOSING_RETURN_ADDRESS (comp_unassigned_p_restart)
  3059. LOSING_RETURN_ADDRESS (comp_unbound_p_restart)
  3060. LOSING_RETURN_ADDRESS (comp_assignment_restart)
  3061. LOSING_RETURN_ADDRESS (comp_definition_restart)
  3062. LOSING_RETURN_ADDRESS (comp_safe_reference_restart)
  3063. LOSING_RETURN_ADDRESS (comp_lookup_trap_restart)
  3064. LOSING_RETURN_ADDRESS (comp_assignment_trap_restart)
  3065. LOSING_RETURN_ADDRESS (comp_op_lookup_trap_restart)
  3066. LOSING_RETURN_ADDRESS (comp_cache_lookup_apply_restart)
  3067. LOSING_RETURN_ADDRESS (comp_safe_lookup_trap_restart)
  3068. LOSING_RETURN_ADDRESS (comp_unassigned_p_trap_restart)
  3069. LOSING_RETURN_ADDRESS (comp_link_caches_restart)
  3070. LOSING_RETURN_ADDRESS (comp_error_restart)
  3071.  
  3072. /* NOP entry points */
  3073.  
  3074. void
  3075. DEFUN (compiler_reset,
  3076.        (new_block),
  3077.        SCHEME_OBJECT new_block)
  3078. {
  3079.   extern void compiler_reset_error();
  3080.  
  3081.   if (new_block != SHARP_F)
  3082.   {
  3083.     compiler_reset_error();
  3084.   }
  3085.   return;
  3086. }
  3087.  
  3088. void
  3089. DEFUN (compiler_initialize,
  3090.        (fasl_p),
  3091.        long fasl_p)
  3092. {
  3093.   compiler_processor_type = 0;
  3094.   compiler_interface_version = 0;
  3095.   compiler_utilities = SHARP_F;
  3096.   return_to_interpreter =
  3097.     (MAKE_OBJECT (TC_RETURN_CODE, RC_POP_FROM_COMPILED_CODE));
  3098.   return;
  3099. }
  3100.  
  3101. /* Identity procedure */
  3102.  
  3103. long
  3104. DEFUN (coerce_to_compiled,
  3105.        (object, arity, location),
  3106.        SCHEME_OBJECT object AND long arity AND SCHEME_OBJECT *location)
  3107. {
  3108.   *location = object;
  3109.   return (PRIM_DONE);
  3110. }
  3111.  
  3112. #endif    /* HAS_COMPILER_SUPPORT */
  3113.